home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacMETH 3.2.1 / Sources / MacC2.6 / M2HM.MOD < prev    next >
Encoding:
Modula Implementation  |  1992-05-29  |  85.6 KB  |  2,177 lines  |  [TEXT/MEDT]
  1. IMPLEMENTATION MODULE M2HM; (* Hermann Seiler 19.4.85 / 10.6.86 / 19.12.91 *)
  2.  
  3.   (* M2HM-implementation for the MOTOROLA MC68000/MC68010 processors. *)
  4.  
  5.   FROM SYSTEM IMPORT
  6.      WORD, LONG, SHIFT, VAL;
  7.   FROM M2SM IMPORT
  8.      Symbol, Mark;
  9.   FROM M2DM IMPORT
  10.      ObjPtr, StrPtr, StrForm, ConstValue, PDesc,
  11.      Object, Structure, Standard,
  12.      notyp, undftyp, booltyp, chartyp,
  13.      inttyp, bitstyp, dbltyp, realtyp, lrltyp,
  14.      proctyp, stringtyp, addrtyp, wordtyp, bytetyp,
  15.      WordSize, MinInt, MaxInt,
  16.      rngchk, ovflchk;
  17.   FROM M2LM IMPORT
  18.      pc, maxP, maxM, PutWord, PutLong, FixLink;
  19.  
  20.  
  21.   CONST
  22.  
  23.      (* Register usage and dedicated registers :   *)
  24.      (* D-Register pool for expression evaluation. *)
  25.  
  26. (*   D0  = 0;   (* freely used, never reserved *)
  27.      D1  = 1;   (* freely used, never reserved *)  *)
  28.      D2  = 2;   (* D-pool, reserved when used  *)
  29.      D3  = 3;   (* D-pool, reserved when used  *)
  30.      D4  = 4;   (* D-pool, reserved when used  *)
  31.      D5  = 5;   (* D-pool, reserved when used  *)
  32.      D6  = 6;   (* D-pool, reserved when used  *)
  33.      D7  = 7;   (* D-pool, reserved when used  *)
  34.  
  35.      (* F-Register pool for floating point arith.  *)
  36.  
  37. (*   F0  = 0;   (* freely used, never reserved *)
  38.      F1  = 1;   (* freely used, never reserved *)  *)
  39.      F2  = 2;   (* F2 - F7 reserved when used  *)
  40.      F7  = 7;
  41.  
  42.      (* A-Register pool for address calculations.  *)
  43.  
  44.      A0  = 0;   (* A-pool, reserved when used  *)
  45.      A1  = 1;   (* A-pool, reserved when used  *)
  46.      A2  = 2;   (* A-pool, reserved when used  *)
  47.      A3  = 3;   (* A-pool, reserved when used  *)
  48.  
  49. (*
  50.      (* Dedicated A-Registers. *)
  51.  
  52.      SB  = 4;   (* SB = A4 : static base pointer   *)
  53.      A5  = 5;   (* A5 is   n e v e r   used !      *)
  54.      MP  = 6;   (* MP = A6 : procedure mark        *)
  55.      SP  = 7;   (* SP = A7 : active stack pointer  *)
  56.  
  57.      (* Instruction size for simple types. *)
  58.  
  59.      byte  =  0;  word  =  1;  long  =  2;
  60.  
  61.      (* Descriptor size dynamic array parameters.  *)
  62.  
  63.      DynArrDesSize = 6;
  64. *)
  65.  
  66.      (* Addressing Mode Categories. *)
  67.  
  68.      DDIR     = 0;       (* D-Reg. direct  *)
  69.      ADIR     = 10B;     (* A-Reg. direct  *)
  70.      AIDR     = 20B;     (*     (An)       *)
  71.      AINC     = 30B;     (*     (An)+      *)
  72.      ADEC     = 40B;     (*    -(An)       *)
  73.      AOFF     = 50B;     (*  d16(An)       *)
  74.      AIDX     = 60B;     (*   d8(An,Rx)    *)
  75.      XXXW     = 70B;     (* absolute short *)
  76.      XXXL     = 71B;     (* absolute long  *)
  77.      PREL     = 72B;     (*  d16(PC)       *)
  78.      IMM      = 74B;     (* immediate or SR*)
  79.  
  80.  
  81.      (* MC68000 instruction mnemonics. *)
  82.      (* _____________________________  *)
  83.  
  84.      (* Special purpose. *)
  85.      UNLK     = 047136B; (* UNLK MP *)
  86.      LINK     = 047126B; (* LINK MP,#d16 *)
  87.      LEASP    = 047757B; (* LEA d16(SP),SP *)
  88.      INCSP    = 050217B; (* ADDQ.L #n,SP *)
  89.      DECSP    = 050617B; (* SUBQ.L #n,SP *)
  90.      MOVEMDEC = 044347B; (* MOVEM.L registers,-(SP) *)
  91.      MOVEMINC = 046337B; (* MOVEM.L (SP)+,registers *)
  92.      MVEMSP   = 027400B; (* MOVE.L  ea,-(SP) : push *)
  93.      MVESPP   = 020037B; (* MOVE.L  (SP)+,ea : pop  *)
  94.      PUSHSB   = 027410B + SB;       (* MOVE.L  SB,-(SP) *)
  95.      POPSB    = 020137B + SB*1000B; (* MOVEA.L (SP)+,SB *)
  96.      MOVEMSTD = 044300B; (* MOVEM.L regs,ea *)
  97.      MOVEMLDD = 046300B; (* MOVEM.L ea,regs *)
  98.      MOVELIMM = 020074B; (* MOVE.L  #imm,ea *)
  99.  
  100.      (* Instructions without operand. *)
  101.      NOP  = 047161B; RTE  = 047163B;
  102.      RTS  = 047165B; RTD  = 047164B; (* MC68010 *)
  103.      TRAPV= 047166B; ILL  = 045374B;
  104.  
  105.      (* Branches : with a displacement. *)
  106.      BRA  = 060000B; BSR  = 060400B;
  107.      BHI  = 061000B; BLS  = 061400B; BCC  = 062000B; BCS  = 062400B;
  108.      BNE  = 063000B; BEQ  = 063400B; BVC  = 064000B; BVS  = 064400B;
  109.      BPL  = 065000B; BMI  = 065400B; BGE  = 066000B; BLT  = 066400B;
  110.      BGT  = 067000B; BLE  = 067400B;
  111.  
  112.      (* Branches : a register and a displacement. *)
  113.      DBT  = 050310B; DBRA = 050710B;
  114.      DBHI = 051310B; DBLS = 051710B; DBCC = 052310B; DBCS = 052710B;
  115.      DBNE = 053310B; DBEQ = 053710B; DBVC = 054310B; DBVS = 054710B;
  116.      DBPL = 055310B; DBMI = 055710B; DBGE = 056310B; DBLT = 056710B;
  117.      DBGT = 057310B; DBLE = 057710B;
  118.  
  119.      (* Set according to condition an effective address. *)
  120.      ST   = 050300B;
  121.  
  122.      (* Operand is a specific register. *)
  123.      SWAP = 044100B;
  124.      EXTW = 044200B; (* EXT.W byte to word *)
  125.      EXTL = 044300B; (* EXT.L word to long *)
  126.  
  127.      (* Operand is an effective address. *)
  128.      CLR  = 041000B; NEG  = 042000B;
  129.      TST  = 045000B; COM  = 043000B; (* synonym for NOT *)
  130.      JMP  = 047300B; JSR  = 047200B;
  131.      PEA  = 044100B; TAS  = 045300B;
  132.      INC1 = 051000B; (* ADDQ #1,ea *)
  133.      DEC1 = 051400B; (* SUBQ #1,ea *)
  134.  
  135.      (* Operand is an immediate value. *)
  136.      TRAP = 047100B; (* TRAP #vector *)
  137.      EMUF = 170000B; (* Line F *)
  138.      EMUA = 120000B; (* Line A *)
  139.  
  140.      (* Operands are a register and an effective address. *)
  141.      ADD  = 150000B; SUB  = 110000B;
  142.      CMP  = 130000B; EORL = 130400B; (* synonym for exclusive OR *)
  143.      ANDL = 140000B; (* synonym for AND *)
  144.      ORL  = 100000B; (* synonym for inclusive OR *)
  145.      CHK  = 040600B; LEA  = 040700B;
  146.      DIVS = 100700B; DIVU = 100300B;
  147.      MULS = 140700B; MULU = 140300B;
  148.      ADDAL= 150700B; (* ADDA.L ea,An *)
  149.      CMPAL= 130700B; (* CMPA.L ea,An *)
  150.      SUBAL= 110700B; (* SUBA.L ea,An *)
  151.      EXGL = 140500B; (* EXG.L  Dn,Dm *)
  152.  
  153.      (* Immediate data within op. and an effective address. *)
  154.      ADDQ = 050000B; SUBQ = 050400B;
  155.  
  156.      (* Shift register by count. *)
  157.      ASL  = 160400B; ASR  = 160000B; LSL  = 160410B; LSR  = 160010B;
  158.      ROL  = 160430B; ROR  = 160030B;
  159.  
  160.      (* Immediate data within extension and an effective address. *)
  161.      ADDI = 003000B; ANDI = 001000B; CMPI = 006000B;
  162.      EORI = 005000B; ORI  = 000000B; SUBI = 002000B;
  163.  
  164.      (* Bit manipulation. *)
  165.      BTST = 000400B; BCHG = 000500B; BCLR = 000600B; BSET = 000700B;
  166.  
  167.      (* Move groups. *)
  168.      MOVEB     = 010000B; (* group 1 *)
  169.      MOVEW     = 030000B; (* group 3 *)
  170.      MOVEL     = 020000B; (* group 2 *)
  171.      MOVEAW    = 030100B; (* MOVEA.W ea,An *)
  172.      MOVEAL    = 020100B; (* MOVEA.L ea,An *)
  173.      MOVEQ     = 070000B; (* MOVE.L #imm,Dn *)
  174.      MOVEFRSR  = 040300B; (* MOVE.W SR,ea *)
  175.      MOVETOSR  = 043300B; (* MOVE.W ea,SR *)
  176.  
  177.      (* concerning the STATUS register. *)
  178.      NBIT      = 8;       (* negative bit *)
  179.      ZBIT      = 4;       (* zero bit *)
  180.      VBIT      = 2;       (* overflow bit *)
  181.      CBIT      = 1;       (* carry bit *)
  182.  
  183.      (* Left shift constants. *)
  184.      LS3  =  10B;  LS4  =  20B;  LS5  =  40B;   LS6  =  100B;
  185.      LS7  = 200B;  LS8  = 400B;  LS9  =  1000B; LS10 =  2000B;
  186.      LS11 = 4000B; LS12 = 10000B;
  187.  
  188.      (* System procedure numbers used by the compiler :          *)
  189.      (* These numbers must correspond with the procedure numbers *)
  190.      (* associated with a specific procedure in the definition   *)
  191.      (* module 'System'.                                         *)
  192.  
  193.      BodyOfSystem        = 0; (* 0 is reserved for module body       *)
  194.      HALTX               = 1; (* System.HALTX  = HALT-statement      *)
  195.      MULU32              = 2; (* System.MULU32 = unsigned long MUL   *)
  196.      DIVU32              = 3; (* System.DIVU32 = unsig. long DIV/MOD *)
  197.      MULS32              = 4; (* System.MULS32 = signed long MUL     *)
  198.      DIVS32              = 5; (* System.DIVS32 = signed long DIV/MOD *)
  199.      FADDs               = 6; (* System.FADDs  = Floating ADD single *)
  200.      FSUBs               = 7; (* System.FSUBs  = Floating SUB single *)
  201.      FMULs               = 8; (* System.FMULs  = Floating MUL single *)
  202.      FDIVs               = 9; (* System.FDIVs  = Floating DIV single *)
  203.      FREMs               = 10;(* System.FREMs  = Floating REM single *)
  204.      FCMPs               = 11;(* System.FCMPs  = Floating CMP single *)
  205.      FNEGs               = 12;(* System.FNEGs  = Floating NEG single *)
  206.      FABSs               = 13;(* System.FABSs  = Floating ABS single *)
  207.      FLOATs              = 14;(* System.FLOATs = FLOAT single        *)
  208.      TRUNCs              = 15;(* System.TRUNCs = TRUNC single        *)
  209.      FADDd               = 16;(* System.FADDd  = Floating ADD double *)
  210.      FSUBd               = 17;(* System.FSUBd  = Floating SUB double *)
  211.      FMULd               = 18;(* System.FMULd  = Floating MUL double *)
  212.      FDIVd               = 19;(* System.FDIVd  = Floating DIV double *)
  213.      FREMd               = 20;(* System.FREMd  = Floating REM double *)
  214.      FCMPd               = 21;(* System.FCMPd  = Floating CMP double *)
  215.      FNEGd               = 22;(* System.FNEGd  = Floating NEG double *)
  216.      FABSd               = 23;(* System.FABSd  = Floating ABS double *)
  217.      FLOATd              = 24;(* System.FLOATd = FLOAT double        *)
  218.      TRUNCd              = 25;(* System.TRUNCd = TRUNC double        *)
  219.      FLONG               = 26;(* System.FLONG  = Floating single to double *)
  220.      FSHORT              = 27;(* System.FSHORT = Floating double to single *)
  221.  
  222.  
  223.   VAR
  224.  
  225.      Rpool, Rbusy, Rlock : BITSET;
  226.      MoveCode            : ARRAY WidType OF CARDINAL;
  227.      ShiCode             : ARRAY [ Asl .. Ror ] OF CARDINAL;
  228.      mask                : ARRAY [ 0 .. 32 ] OF LONGINT;
  229.      hightyp             : StrPtr;
  230.  
  231.   PROCEDURE ProcessorID(VAR id: Processor);
  232.   BEGIN
  233.     id := "MC68000"
  234.   END ProcessorID;
  235.  
  236.   PROCEDURE err(n : CARDINAL);
  237.     (* local synonym for M2SM.Mark to save space! *)
  238.   BEGIN
  239.     Mark(n);
  240.   END err;
  241.  
  242.   PROCEDURE Put16(w : WORD);
  243.     (* local synonym for M2LM.PutWord to save space! *)
  244.   BEGIN
  245.     PutWord(w);
  246.   END Put16;
  247.  
  248.   PROCEDURE Put32(l : LONGINT);
  249.     (* local synonym for M2LM.PutLong to save space! *)
  250.   BEGIN
  251.     PutLong(l);
  252.   END Put32;
  253.  
  254.   PROCEDURE SignedT(VAR x : Item) : BOOLEAN;
  255.     (*      is x a signed type ?       *)
  256.     (* Note :  Real/LongReal excluded! *)
  257.     VAR s : StrPtr;
  258.   BEGIN
  259.     s := x.typ; (* let x.typ unchanged *)
  260.     IF s^.form = Range THEN s := s^.RBaseTyp END;
  261.     RETURN (s = inttyp) OR (s = dbltyp)
  262.   END SignedT;
  263.  
  264.   PROCEDURE SimpleT(VAR x : Item) : BOOLEAN;
  265.     (*   is x a simple type of size   *)
  266.     (*         byte/word/long ?       *)
  267.     (* Note : Real/LongReal excluded! *)
  268.     VAR f : StrForm; s : StrPtr; sz : CARDINAL;
  269.   BEGIN
  270.     s := x.typ; (* let x.typ unchanged *)
  271.     IF s^.form = Range THEN s := s^.RBaseTyp END;
  272.     f := s^.form; sz := VAL(CARDINAL,s^.size);
  273.     RETURN (sz IN {1,2,4}) AND ((f <= Double) OR (f = Pointer) OR
  274.             (f = Set) OR (f = ProcTyp) OR (f = Opaque))
  275.   END SimpleT;
  276.  
  277.   PROCEDURE RealT(VAR x : Item) : BOOLEAN;
  278.     (*  is x a floating-point-type ?  *)
  279.     (*       (REAL or LONGREAL)       *)
  280.     (* Note: floating-point-types are *)
  281.     (*       NOT considered as simple *)
  282.     VAR s : StrPtr;
  283.   BEGIN
  284.     s := x.typ; (* let x.typ unchanged *)
  285.     RETURN (s = realtyp) OR (s = lrltyp)
  286.   END RealT;
  287.  
  288.   PROCEDURE SimpleC(VAR x : Item) : BOOLEAN;
  289.     (* is x a simple constant of size *)
  290.     (*         byte/word/long ?       *)
  291.     (* Note : Real/LongReal excluded! *)
  292.   BEGIN
  293.     RETURN (x.mode = conMd) & SimpleT(x)
  294.   END SimpleC;
  295.  
  296.   PROCEDURE LongVal(VAR x : Item) : LONGINT;
  297.     VAR r : LONGINT;
  298.   BEGIN r := 0D;
  299.     WITH x DO
  300.       IF typ^.form = Range THEN typ := typ^.RBaseTyp END;
  301.       CASE typ^.form OF
  302.         Undef :        IF typ^.size = 1 THEN r := LONG(val.Ch)
  303.                        ELSIF typ^.size = 2 THEN r := LONG(val.C)
  304.                        ELSE r := val.U END;
  305.       | Bool :         r := LONG(val.B);
  306.       | Char :         r := LONG(val.Ch);
  307.       | Card, CardInt: r := LONG(val.C);
  308.       | Int :          r := LONG(val.I);
  309.       | Enum :         r := LONG(val.Ch);
  310.       | Set :          r := VAL(LONGINT, val.S);
  311.       | LCard,Double : r := val.D;
  312.       | Real :         r := VAL(LONGINT, val.R);
  313.       ELSE             r := val.D; (* String, etc. *)
  314.       END;
  315.     END (*WITH*);
  316.     RETURN r
  317.   END LongVal;
  318.  
  319.   PROCEDURE WordVal(VAR x : Item) : INTEGER;
  320.     VAR r : INTEGER;
  321.   BEGIN r := 0;
  322.     WITH x DO
  323.       IF typ^.form = Range THEN typ := typ^.RBaseTyp END;
  324.       CASE typ^.form OF
  325.         Undef :        IF typ^.size = 1 THEN r := ORD(val.Ch)
  326.                        ELSIF typ^.size=2 THEN r := VAL(INTEGER,val.C)
  327.                        ELSE r := VAL(INTEGER, val.U) END;
  328.       | Bool :         r := ORD(val.B);
  329.       | Char :         r := ORD(val.Ch);
  330.       | Card, CardInt: r := VAL(INTEGER, val.C);
  331.       | Int :          r := val.I;
  332.       | Enum :         r := ORD(val.Ch);
  333.       | Set :          r := VAL(INTEGER, val.S);
  334.       | LCard,Double : r := VAL(INTEGER, val.D);
  335.       | Real :         r := VAL(INTEGER, VAL(LONGINT, val.R));
  336.       ELSE             r := VAL(INTEGER, val.D); (* String, etc. *)
  337.       END;
  338.     END (*WITH*);
  339.     RETURN r
  340.   END WordVal;
  341.  
  342.   PROCEDURE ZeroVal(VAR x : Item) : BOOLEAN;
  343.     VAR b : BOOLEAN;
  344.   BEGIN b := FALSE;
  345.     IF x.mode = conMd THEN
  346.       IF    x.typ = realtyp THEN b := x.val.R = FLOAT(0)
  347.       ELSIF x.typ = lrltyp  THEN b := x.val.X = FLOATD(0)
  348.       END;
  349.     END;
  350.     RETURN b
  351.   END ZeroVal;
  352.  
  353.   PROCEDURE Iea(fea : CARDINAL) : CARDINAL;
  354.     (* invert the 'mode/register' effective address *)
  355.     (* to 'register/mode' representation.           *)
  356.   BEGIN
  357.     RETURN (fea MOD 8)*8 + (fea DIV 8)
  358.   END Iea;
  359.  
  360.   PROCEDURE Isz(VAR x : Item; VAR fsz : WidType);
  361.     (* instruction size for item x : byte/word/long. *)
  362.     (* Note :  callable only for simple types !      *)
  363.     VAR s : INTEGER; sz : WidType;
  364.   BEGIN
  365.     s := x.typ^.size;
  366.     IF    s = 1 THEN sz := byte
  367.     ELSIF s = 2 THEN sz := word
  368.     ELSIF s = 4 THEN sz := long
  369.     ELSE sz := long; err(238); (* invalid instruction size *)
  370.     END;
  371.     fsz := sz
  372.   END Isz;
  373.  
  374.   PROCEDURE SetglbMd(VAR x : Item; fadr : INTEGER; ftyp : StrPtr);
  375.     (* setup of an item designating a global variable *)
  376.   BEGIN
  377.     WITH x DO
  378.       IF ftyp <> NIL THEN typ := ftyp ELSE typ := undftyp END;
  379.       mode := RindMd;  mod := 0;   lev   := 0;
  380.       adr  := fadr;    off := 0;   indir := FALSE;
  381.       R    := SB + 8;
  382.     END (*WITH*);
  383.   END SetglbMd;
  384.  
  385.   PROCEDURE SetlocMd(VAR x : Item; fadr : INTEGER; ftyp : StrPtr);
  386.     (* setup of an item which is relative to the Marker MP *)
  387.   BEGIN
  388.     WITH x DO
  389.       IF ftyp <> NIL THEN typ := ftyp ELSE typ := undftyp END;
  390.       mode := RindMd;  mod := 0;   lev   := curLev;
  391.       adr  := fadr;    off := 0;   indir := FALSE;
  392.       R    := MP + 8;
  393.     END (*WITH*);
  394.   END SetlocMd;
  395.  
  396.   PROCEDURE SetregMd(VAR x : Item; freg : Register; ftyp : StrPtr);
  397.     (* setup of an item designating a (long) register. *)
  398.   BEGIN
  399.     WITH x DO
  400.       IF ftyp <> NIL THEN typ := ftyp ELSE typ := undftyp END;
  401.       IF freg <= D7  THEN mode := DregMd ELSE mode := AregMd END;
  402.       mod := 0;     lev := curLev;
  403.       adr := 0;     off := 0;    indir := FALSE;
  404.       R   := freg;  wid := long;
  405.     END (*WITH*);
  406.   END SetregMd;
  407.  
  408.   PROCEDURE SetstkMd(VAR x : Item; ftyp : StrPtr);
  409.     (* setup of an item on top of stack. *)
  410.   BEGIN
  411.     WITH x DO
  412.       IF ftyp <> NIL THEN typ := ftyp ELSE typ := undftyp END;
  413.       mode := stkMd;  mod := 0;   lev   := curLev;
  414.       adr  := 0;      off := 0;   indir := FALSE;
  415.       R    := SP + 8;
  416.     END (*WITH*);
  417.   END SetstkMd;
  418.  
  419.   PROCEDURE SetfltMd(VAR x : Item; fR : Register; ftyp : StrPtr);
  420.   BEGIN
  421.     WITH x DO
  422.       IF ftyp = realtyp THEN     (* for single real          *)
  423.         SetregMd(x, fR, ftyp);   (* resulting mode = DregMd! *)
  424.       ELSE
  425.         typ := ftyp;             (* for double real          *)
  426.         mode := fltMd; FR := fR; (* resulting mode = fltMd ! *)
  427.       END;
  428.     END (*WITH*);
  429.   END SetfltMd;
  430.  
  431.   PROCEDURE SetconMd(VAR x : Item; fval : LONGINT; ftyp : StrPtr);
  432.     VAR v : ConstValue;
  433.   BEGIN
  434.     WITH x DO
  435.       IF ftyp <> NIL THEN typ := ftyp ELSE typ := undftyp END;
  436.       IF typ^.form = Range THEN typ := typ^.RBaseTyp END;
  437.       mode  := conMd;
  438.       CASE typ^.form OF
  439.         Undef :    IF typ^.size = 1 THEN v.Ch := VAL(CHAR, fval)
  440.                    ELSIF typ^.size = 2 THEN v.C := VAL(CARDINAL, fval)
  441.                    ELSE v.U  := fval END;
  442.       | Bool :     v.B  := VAL(BOOLEAN, fval);
  443.       | Char :     v.Ch := VAL(CHAR, fval);
  444.       | Card,
  445.         CardInt :  v.C  := VAL(CARDINAL, fval);
  446.       | Int :      v.I  := VAL(INTEGER, fval);
  447.       | Enum :     v.Ch := VAL(CHAR, fval);
  448.       | LCard :    v.D  := fval;
  449.       | Double :   v.D  := fval;
  450.       | Real :     v.R  := VAL(REAL, fval);
  451.       | Set :      v.S  := VAL(BITSET, fval);
  452.       ELSE         v.D  := fval; (* String, etc. *)
  453.       END;
  454.       val := v;
  455.     END (*WITH*);
  456.   END SetconMd;
  457.  
  458.   PROCEDURE SetbusyReg(r : Register);
  459.   BEGIN
  460.     IF r IN Rpool THEN INCL(Rbusy,r) END;
  461.   END SetbusyReg;
  462.  
  463.   PROCEDURE SaveRegs(VAR save : LONGINT);
  464.     (* save the busy registers and return the list *)
  465.     (* of the saved registers in 'save'.           *)
  466.     (*                                             *)
  467.     (* Note : the saved registers are NOT released *)
  468.     (* ----   and remain busy !                    *)
  469.     (*        SP is never saved nor restored !     *)
  470.     (*                                             *)
  471.     VAR r, lr : Register; x, reglist, n : CARDINAL;
  472.         regs  : RECORD
  473.                   CASE :BOOLEAN OF
  474.                      TRUE : All : LONGINT
  475.                    | FALSE: FPU, CPU : CARDINAL
  476.                   END
  477.                 END;
  478.   BEGIN regs.All := 0D;
  479.     (* the global (CPU) registers : *)
  480.     x := 1; reglist := 0; r := SP + 8; n := 0;
  481.     REPEAT (* from SP-1 downto D0 *)
  482.       DEC(r); x := x + x;
  483.       IF (r IN Rpool) & (r IN Rbusy) THEN
  484.         INC(n); lr := r;
  485.         reglist := reglist + x;
  486.       END;
  487.     UNTIL r = D0;
  488.     IF reglist <> 0 THEN
  489.       IF n = 1 THEN Put16(MVEMSP + lr)
  490.       ELSE Put16(MOVEMDEC); Put16(reglist) END;
  491.     END;
  492.     regs.CPU := reglist; (* global register set *)
  493.     save := regs.All;
  494.   END SaveRegs;
  495.  
  496.   PROCEDURE RestoreRegs(save : LONGINT);
  497.     (* restore the registers given by 'save'. *)
  498.     VAR r, lr : Register; x, reglist, n : CARDINAL;
  499.         regs  : RECORD
  500.                   CASE :BOOLEAN OF
  501.                      TRUE : All : LONGINT
  502.                    | FALSE: FPU, CPU : CARDINAL
  503.                   END
  504.                 END;
  505.   BEGIN regs.All := save;
  506.     (* the global (CPU) registers : *)
  507.     x := 32768; reglist := 0; r := SP + 8; n := 0;
  508.     REPEAT (* from SP-1 downto D0 *)
  509.       DEC(r); x := x DIV 2; regs.CPU := regs.CPU DIV 2;
  510.       IF ODD(regs.CPU) THEN
  511.         INC(n); lr := r;
  512.         reglist := reglist + x;
  513.       END;
  514.     UNTIL r = D0;
  515.     IF reglist <> 0 THEN
  516.       IF n = 1 THEN Put16(MVESPP + Iea(lr)*LS6)
  517.       ELSE Put16(MOVEMINC); Put16(reglist) END;
  518.     END;
  519.   END RestoreRegs;
  520.  
  521.   PROCEDURE Islocked(r : Register) : BOOLEAN;
  522.   BEGIN
  523.     RETURN (r IN Rlock)
  524.   END Islocked;
  525.  
  526.   PROCEDURE ReleaseReg(r : Register);
  527.   BEGIN
  528.     IF NOT(r IN Rlock) THEN EXCL(Rbusy,r) END;
  529.   END ReleaseReg;
  530.  
  531.   PROCEDURE LockReg(r : Register);
  532.   BEGIN
  533.     INCL(Rlock,r);
  534.   END LockReg;
  535.  
  536.   PROCEDURE UnlockReg(r : Register);
  537.     (* must be followed by ReleaseReg when r is released *)
  538.   BEGIN
  539.     EXCL(Rlock,r);
  540.   END UnlockReg;
  541.  
  542.   PROCEDURE Release(VAR x : Item);
  543.   BEGIN
  544.     WITH x DO
  545.       IF mode IN ItSet{RindMd,RidxMd,AregMd,DregMd} THEN
  546.         IF R IN Rpool THEN ReleaseReg(R) END;
  547.       ELSIF (mode = fltMd) THEN
  548.         (* temporary solution for SANE *)
  549.         IF FR IN Rpool THEN ReleaseReg(FR); ReleaseReg(FR+1) END;
  550.       END;
  551.       IF mode = RidxMd THEN ReleaseReg(RX) END;
  552.     END (*WITH*);
  553.   END Release;
  554.  
  555.   PROCEDURE GetReg(VAR r : Register; qual : RegType);
  556.     VAR hr, lr : Register;
  557.   BEGIN
  558.     IF qual = Areg THEN hr := A3 + 8; lr := A0 + 8
  559.     ELSE hr := D2; lr := D7 END;
  560.     LOOP
  561.       IF NOT(hr IN Rbusy) THEN
  562.         r := hr; SetbusyReg(hr); EXIT
  563.       END;
  564.       IF hr = lr THEN
  565.         err(215); r := lr;    (* register overflow *)
  566.         ReleaseReg(lr); EXIT  (* avoid endless loop *)
  567.       END;
  568.       IF qual = Dreg THEN
  569.         (* D2 -> D4 -> D6 -> D3 -> D5 -> D7 *)
  570.         IF hr = D6 THEN hr := D3
  571.         ELSE hr := hr + 2 END
  572.       ELSE (* qual = Areg *)
  573.         (* A3 -> A2 -> A1 -> A0 *)
  574.         hr := hr - 1
  575.       END;
  576.     END (*LOOP*);
  577.   END GetReg;
  578.  
  579.   PROCEDURE GetFReg(VAR r : Register);
  580.     (* reserve a pair of adjacent D-Registers. *)
  581.     (* Note : only for D-Registers!            *)
  582.     VAR hr : Register;
  583.   BEGIN
  584.     hr := D2;
  585.     LOOP
  586.       IF NOT(hr IN Rbusy) & NOT( (hr+1) IN Rbusy ) THEN
  587.         r := hr; SetbusyReg(hr); SetbusyReg(hr+1); EXIT
  588.       END;
  589.       IF hr = D6 THEN
  590.         err(215); r := D6;              (* D-Register overflow *)
  591.         ReleaseReg(D6); ReleaseReg(D7); (* avoid endless loop *)
  592.         EXIT
  593.       ELSE
  594.         (*  (D2,D3) -> (D4,D5) -> (D6,D7) *)
  595.         hr := hr + 2
  596.       END;
  597.     END (*LOOP*);
  598.   END GetFReg;
  599.  
  600.   PROCEDURE InitRegs;
  601.   BEGIN
  602.     Rpool := { D2 .. D7, A0+8 .. A3+8 };
  603.     Rlock := { SB+8 .. SP+8 };
  604.     Rbusy := Rlock;
  605.   END InitRegs;
  606.  
  607.   PROCEDURE CheckRegs;
  608.   BEGIN
  609.     IF Rbusy <> Rlock THEN
  610.       err(234);
  611.       Rbusy := Rlock;
  612.     END;
  613.   END CheckRegs;
  614.  
  615.   PROCEDURE InvertCC(cond : Condition) : Condition;
  616.     (* generate the 'inverted' condition. *)
  617.     VAR c : CARDINAL;
  618.   BEGIN c := ORD(cond);
  619.     IF c < 16 THEN
  620.       IF ODD(c) THEN DEC(cond) ELSE INC(cond) END;
  621.     ELSE
  622.       c := c - 16;
  623.       c := 15 - c;
  624.       c := c + 16;
  625.       cond := VAL(Condition, c);
  626.     END;
  627.     RETURN cond
  628.   END InvertCC;
  629.  
  630.   PROCEDURE CodeCC(cond : Condition) : CARDINAL;
  631.     (* generate the code for conditions. *)
  632.     VAR c : Condition;
  633.   BEGIN
  634.     CASE cond OF (* for floating point conditions *)
  635.       FF  :   c := F;
  636.     | FEQ :   c := EQ;
  637.     | FGT :   c := GT;
  638.     | FGE :   c := GE;
  639.     | FLT :   c := CS; (* for SANE *)
  640.     | FLE :   c := LS; (* for SANE *)
  641.     | FGL :   c := VS;
  642.     | FGLE :  c := VC;
  643.     | FNGLE : c := VS;
  644.     | FNGL :  c := VC;
  645.     | FNLE :  c := GT;
  646.     | FNLT :  c := GE;
  647.     | FNGE :  c := CS; (* for SANE *)
  648.     | FNGT :  c := LS; (* for SANE *)
  649.     | FNE :   c := NE;
  650.     | FT :    c := T;
  651.     ELSE (* the same condition *)
  652.       c := cond;
  653.     END (*CASE*);
  654.     RETURN VAL(CARDINAL, c)
  655.   END CodeCC;
  656.  
  657.   PROCEDURE Jf(cond : Condition; VAR l : CARDINAL);
  658.     (* jump forward, build chain. *)
  659.   BEGIN
  660.     (* MC68000 does NOT have a "Branch on Never True" ! *)
  661.     IF cond = F THEN Put16(CMPI) ELSE Put16(BRA + CodeCC(cond)*LS8) END;
  662.     Put16(l);
  663.     l := pc - 2; (* location of word-displacement *)
  664.   END Jf;
  665.  
  666.   PROCEDURE Jb(cond : Condition; l : CARDINAL);
  667.     (* jump backward, no chain. *)
  668.     VAR dd : CARDINAL; d : INTEGER;
  669.   BEGIN
  670.     d  := VAL(INTEGER,l) - VAL(INTEGER,pc) - 2;
  671.     dd := VAL(CARDINAL,d);
  672.     IF (d >= -128) & (cond # F) THEN (* short branch *)
  673.       Put16(BRA + CodeCC(cond)*LS8 + (dd MOD 256))
  674.     ELSE
  675.       Jf(cond,dd)
  676.     END;
  677.   END Jb;
  678.  
  679.   PROCEDURE Scc(cond : Condition; Dn : Register);
  680.     (* set D-Register according to condition. *)
  681.   BEGIN
  682.     Put16(ST + CodeCC(cond)*LS8 + DDIR + Dn);
  683.     Put16(NEG + byte*LS6 + DDIR + Dn);
  684.   END Scc;
  685.  
  686.   PROCEDURE LoadCC(VAR x : Item);
  687.     (* convert from 'cocMd' to 'DregMd' while *)
  688.     (* generating conditional code.           *)
  689.     VAR Dn : Register;
  690.   BEGIN
  691.     WITH x DO
  692.       GetReg(Dn,Dreg);
  693.       IF (Tjmp = 0) & (Fjmp = 0) THEN
  694.         Scc(InvertCC(CC), Dn);
  695.         (* transform 'cocMd' to 'DregMd' *)
  696.         SetregMd(x, Dn, booltyp);
  697.         wid := byte;
  698.       ELSE
  699.         Jf(CC, Fjmp);
  700.         FixLink(Tjmp);
  701.         Put16(MOVEQ + Dn*LS9 + 1);
  702.         Put16(BRA + 2);
  703.         FixLink(Fjmp);
  704.         Put16(MOVEQ + Dn*LS9 + 0);
  705.         (* transform 'cocMd' to 'DregMd' *)
  706.         SetregMd(x, Dn, booltyp);
  707.         wid := long;
  708.       END;
  709.     END (*WITH*);
  710.   END LoadCC;
  711.  
  712.   PROCEDURE ExternalCall(mno, pno : CARDINAL);
  713.     (* call of the external procedure #pno in module #mno. *)
  714.     VAR An : Register;
  715.   BEGIN
  716.     GetReg(An,Areg); (* An IN { 8 .. 15 } *)
  717.     An := An MOD 8;
  718.     Put16(MOVEAL + An*LS9 + AOFF + SB);   (* MOVEA.L (maxP+mno)*4(SB),An *)
  719.     Put16((maxP + mno)*4);
  720.     IF pno = 0 THEN
  721.       Put16(MOVEAL + An*LS9 + AIDR + An); (* MOVEA.L (An),An      *)
  722.     ELSE
  723.       Put16(MOVEAL + An*LS9 + AOFF + An); (* MOVEA.L pno*4(An),An *)
  724.       Put16(pno*4);
  725.     END;
  726.     Put16(JSR + AIDR + An);               (* JSR (An) *)
  727.     ReleaseReg(An + 8);
  728.   END ExternalCall;
  729.  
  730.   PROCEDURE downlevel(VAR x : Item);
  731.     (* for level difference >= 1. *)
  732.     CONST offSL = 8; (* offset of Static Link *)
  733.     VAR   N,An : Register; n : CARDINAL;
  734.   BEGIN
  735.     GetReg(N,Areg);    (* N IN { 8..15 } *)
  736.     An := N MOD 8;
  737.     Put16(MOVEAL + An*LS9 + AOFF + MP);   (* MOVEA.L offSL(MP),An *)
  738.     Put16(offSL);
  739.     n := curLev - x.lev;
  740.     WHILE n > 1 DO
  741.       DEC(n);
  742.       Put16(MOVEAL + An*LS9 + AOFF + An); (* MOVEA.L offSL(An),An *)
  743.       Put16(offSL);
  744.     END;
  745.     ReleaseReg(x.R);
  746.     x.R := N;
  747.   END downlevel;
  748.  
  749.   PROCEDURE Ext(VAR x : Item);
  750.     (* effective address extension of x. *)
  751.     VAR ext : CARDINAL; sz : INTEGER;
  752.   BEGIN
  753.     WITH x DO
  754.       CASE mode OF
  755.         absMd :          Put32(adr);
  756.       | RindMd :         IF adr <> 0 THEN Put16(adr) END;
  757.       | RidxMd :         IF wid = word THEN ext := RX*LS12 + scl*LS9
  758.                          ELSE ext := RX*LS12 + LS11 + scl*LS9 END;
  759.                          Put16(ext + (VAL(CARDINAL,adr) MOD 256));
  760.       | conMd :          IF typ = stringtyp THEN
  761.                            Put16(val.D0+VAL(INTEGER, maxP+maxM)*4)
  762.                          ELSE sz := typ^.size;
  763.                            IF    sz = 1 THEN Put16(WordVal(x))
  764.                            ELSIF sz = 2 THEN Put16(WordVal(x))
  765.                            ELSIF sz = 4 THEN Put32(LongVal(x))
  766.                            ELSIF sz = 8 THEN
  767.                              Put16(val.D0); Put16(val.D1);
  768.                              Put16(val.D2); Put16(val.D3);
  769.                            END;
  770.                          END;
  771.       | stkMd :          (* no extension *)
  772.       | AregMd,DregMd :  (* no extension *)
  773.       | procMd :         IF (proc <> NIL) & (proc^.pd <> NIL) &
  774.                             (proc^.pd^.adr <> 0) THEN
  775.                            (* local procedure *)
  776.                            Put16(proc^.pd^.adr - VAL(INTEGER,pc));
  777.                          ELSE (* external procedure *)
  778.                            (* no extension *)
  779.                          END;
  780.       | prgMd :          Put16(VAL(INTEGER,where) - VAL(INTEGER,pc));
  781.       | typMd,codMd :    (* no extension *)
  782.       | cocMd,fltMd :    (* no extension *)
  783.       END (*CASE*);
  784.     END (*WITH*);
  785.   END Ext;
  786.  
  787.   PROCEDURE ReduceIndir(VAR x : Item; ea : CARDINAL);
  788.     (* Note : A-Registers internally numbered from 8 .. 15! *)
  789.     VAR src, dst : Register;
  790.   BEGIN
  791.     WITH x DO
  792.       CASE mode OF
  793.         absMd :
  794.           GetReg(dst,Areg);
  795.           Put16(MOVEAL + (dst MOD 8)*LS9 + ea);
  796.           Ext(x);
  797.       | RindMd,RidxMd :
  798.           src := R;
  799.           IF Islocked(src) THEN GetReg(dst,Areg)
  800.           ELSE dst := src END;
  801.           Put16(MOVEAL + (dst MOD 8)*LS9 + ea);
  802.           Ext(x);
  803.           IF dst <> src THEN ReleaseReg(src) END;
  804.           IF mode = RidxMd THEN ReleaseReg(RX) END;
  805.       END (*CASE*);
  806.       (* transform all modes to 'RindMd' *)
  807.       mode := RindMd; R := dst; (* R IN { 8..15 } *)
  808.       indir := FALSE; adr := off; off := 0;
  809.     END (*WITH*);
  810.   END ReduceIndir;
  811.  
  812.   PROCEDURE GeaP(VAR x : Item; VAR fea : CARDINAL);
  813.     (* effective address of an item designating a procedure. *)
  814.     VAR An : Register;
  815.   BEGIN
  816.     WITH x DO
  817.       IF (proc <> NIL) & (proc^.pd <> NIL) &
  818.          (proc^.pd^.adr <> 0) THEN (* local procedure *)
  819.         fea := PREL;
  820.       ELSE (* external procedure *)
  821.         GetReg(An,Areg);
  822.         Put16(MOVEAL + (An MOD 8)*LS9 + AOFF + SB);
  823.         Put16((maxP + VAL(CARDINAL,proc^.pmod))*4);
  824.         Put16(MOVEAL + (An MOD 8)*LS9 + AOFF + (An MOD 8));
  825.         Put16(proc^.pd^.num*4);
  826.         (* transform 'procMd' to 'AregMd' *)
  827.         SetregMd(x, An, typ);
  828.         fea := ADIR + (An MOD 8);
  829.       END;
  830.     END (*WITH*);
  831.   END GeaP;
  832.  
  833.   PROCEDURE Gea(VAR x : Item; VAR fea : CARDINAL);
  834.     (* give effective address of x. *)
  835.     VAR ea : CARDINAL; An : Register;
  836.   BEGIN
  837.     WITH x DO
  838.       CASE mode OF
  839.         absMd :             ea := XXXL;
  840.       | RindMd :            IF R = (MP + 8) THEN
  841.                               IF lev <> curLev THEN downlevel(x) END;
  842.                             END;
  843.                             IF adr <> 0 THEN ea := AOFF + (R MOD 8)
  844.                             ELSE ea := AIDR + (R MOD 8) END;
  845.       | RidxMd :            IF (-128 <= adr) & (adr <= 127) THEN
  846.                               ea := AIDX + (R MOD 8)
  847.                             ELSE (* adr out of 8-bit range *)
  848.                               IF Islocked(R) THEN GetReg(An,Areg)
  849.                               ELSE An := R END;
  850.                               Put16(LEA + (An MOD 8)*LS9 + AIDX + (R MOD 8));
  851.                               IF wid = word THEN Put16(RX*LS12 + scl*LS9)
  852.                               ELSE Put16(RX*LS12 + LS11 + scl*LS9) END;
  853.                               IF R <> An THEN ReleaseReg(R) END;
  854.                               ReleaseReg(RX);
  855.                               (* transform 'RidxMd' to 'RindMd' *)
  856.                               mode := RindMd; ea := AOFF + (An MOD 8);
  857.                               R := An;
  858.                             END (*RidxMd*);
  859.       | conMd :             IF typ = stringtyp THEN
  860.                               ea := AOFF + SB (* SB-relative *)
  861.                             ELSE
  862.                               ea := IMM (* for all sizes *)
  863.                             END;
  864.       | stkMd :             ea := AINC + SP;  (* gives (SP)+ *)
  865.       | AregMd :            ea := ADIR + (R MOD 8);
  866.       | DregMd :            ea := DDIR + (R MOD 8);
  867.       | prgMd :             ea := PREL;
  868.       | typMd, codMd :      ea := DDIR + D0; (* dummy effective address *)
  869.                             err(232);        (* NO address equivalent ! *)
  870.       | procMd, cocMd,
  871.         fltMd :             ea := DDIR + D0; (* dummy effective address *)
  872.                             err(233);        (* should never occur here!*)
  873.       END (*CASE*);
  874.       IF (mode < conMd) & indir THEN
  875.         ReduceIndir(x,ea);
  876.         IF adr <> 0 THEN ea := AOFF + (R MOD 8)
  877.         ELSE ea := AIDR + (R MOD 8) END;
  878.       END;
  879.     END (*WITH*);
  880.     fea := ea ; (* resulting effective address *)
  881.   END Gea;
  882.  
  883.   PROCEDURE OvflTrap(signed : BOOLEAN);
  884.     (* overflow-check thru TRAPV for signed arithmetic : *)
  885.   BEGIN
  886.     IF NOT ovflchk THEN RETURN END;
  887.     IF signed THEN Put16(TRAPV) END;
  888.   END OvflTrap;
  889.  
  890.   PROCEDURE OvflCheck(R : Register; signed : BOOLEAN);
  891.     (* overflow-check for 16*16bit signed multiplication : *)
  892.     VAR Dn : Register;
  893.   BEGIN
  894.     IF NOT ovflchk THEN RETURN END;
  895.     IF signed THEN
  896.       GetReg(Dn,Dreg);                     (* scratch reg. *)
  897.       Put16(MOVEW + Dn*LS9 + R);           (* copy wordpart *)
  898.       Put16(EXTL + Dn);                    (* EXT.L Dn      *)
  899.       Put16(CMP + R*LS9 + long*LS6 + Dn);  (* CMP.L  Dn,R   *)
  900.       Put16(BEQ + 6);                      (* BEQ.S  6      *)
  901.       Put16(ORI + IMM);                    (* ORI.W #VBIT,SR*)
  902.       Put16(VBIT);
  903.       Put16(TRAPV);                        (* TRAPV         *)
  904.       ReleaseReg(Dn);
  905.     END;
  906.   END OvflCheck;
  907.  
  908.   PROCEDURE StackTop(i : INTEGER);
  909.     (* increment/decrement stack pointer SP :  *)
  910.     (*   i > 0 :  increment SP, reset stack    *)
  911.     (*   i < 0 :  decrement SP, reserve stack  *)
  912.     VAR neg : BOOLEAN; c : CARDINAL;
  913.   BEGIN
  914.     IF i <> 0 THEN
  915.       neg := (i < 0);
  916.       IF ODD(i) THEN
  917.         IF neg THEN DEC(i) ELSE INC(i) END;
  918.       END;
  919.       IF (-8 <= i) & (i <= 8) THEN
  920.         c := (VAL(CARDINAL,ABS(i)) MOD 8)*LS9;
  921.         IF neg THEN Put16(DECSP + c)
  922.         ELSE Put16(INCSP + c) END;
  923.       ELSE
  924.         Put16(LEASP);
  925.         Put16(i);
  926.       END;
  927.     END (*i <> 0*);
  928.   END StackTop;
  929.  
  930.   PROCEDURE SetupSL(plev : CARDINAL);
  931.     (* push Static Link onto stack. *)
  932.     CONST  offSL = 8;  (* offset of Static Link relative to MP *)
  933.     VAR N, An : Register; n : CARDINAL;
  934.   BEGIN
  935.     IF plev <> 0 THEN
  936.       IF plev = curLev THEN
  937.         (* level difference = 0 *)
  938.         Put16(PEA + AIDR + MP);             (* PEA     (MP) *)
  939.       ELSIF plev + 1 = curLev THEN
  940.         (* level difference = 1 *)
  941.         Put16(MVEMSP + AOFF + MP);          (* MOVE.L  offSL(MP),-(SP) *)
  942.         Put16(offSL);
  943.       ELSE
  944.         (* level difference >= 2 *)
  945.         GetReg(N,Areg); An := N MOD 8;
  946.         Put16(MOVEAL + An*LS9 + AOFF + MP); (* MOVEA.L offSL(MP),An *)
  947.         Put16(offSL);
  948.         n := curLev - plev;
  949.         WHILE n > 2 DO
  950.           DEC(n);
  951.           Put16(MOVEAL + An*LS9 + AOFF+An); (* MOVEA.L offSL(An),An *)
  952.           Put16(offSL);
  953.         END;
  954.         Put16(MVEMSP + AOFF + An);          (* MOVE.L  offSL(An),-(SP) *)
  955.         Put16(offSL);
  956.         ReleaseReg(N);
  957.       END;
  958.     END (*plev <> 0*);
  959.   END SetupSL;
  960.  
  961.   PROCEDURE InitM2HM;
  962.     VAR k : CARDINAL; exp : LONGINT;
  963.   BEGIN
  964.     curLev := 0;
  965.     MoveCode[byte] := MOVEB; MoveCode[word] := MOVEW;
  966.     MoveCode[long] := MOVEL;
  967.     ShiCode [Asl]  := ASL;   ShiCode [Asr]  := ASR;
  968.     ShiCode [Lsl]  := LSL;   ShiCode [Lsr]  := LSR;
  969.     ShiCode [Rol]  := ROL;   ShiCode [Ror]  := ROR;
  970.     exp := 0D; mask[0] := 0D; mask[32] := -1D;
  971.     FOR k := 1 TO 31 DO exp := exp + exp + 1D; mask[k] := exp END;
  972.     IF DynArrDesSize = 6 THEN hightyp := inttyp
  973.     ELSE hightyp := dbltyp END;
  974.     InitRegs;
  975.   END InitM2HM;
  976.  
  977.   PROCEDURE LoadAdr(VAR x : Item);
  978.     (* ADR(x)   --->>>  pointer/address-register. *)
  979.     VAR ea, am : CARDINAL; An : Register; newA, loaded : BOOLEAN;
  980.   BEGIN
  981.     WITH x DO
  982.       IF (mode IN ItSet{stkMd,AregMd,DregMd,cocMd,typMd,codMd,fltMd})
  983.       OR ((mode = conMd) & (typ <> stringtyp)) THEN
  984.         err(231); (* no effective address possible *)
  985.         Release(x); SetregMd(x, A0+8, undftyp);
  986.       END;
  987.       IF mode = procMd THEN GeaP(x,ea) ELSE Gea(x,ea) END;
  988.       am := (ea DIV 8)*8;
  989.       newA := TRUE; loaded := FALSE;
  990.       IF mode IN ItSet{RindMd,RidxMd,AregMd} THEN
  991.         IF NOT Islocked(R) THEN newA := FALSE END;
  992.       END;
  993.       IF newA THEN GetReg(An,Areg)
  994.       ELSE An := R;
  995.         IF (am = ADIR) OR (am = AIDR) THEN loaded := TRUE END;
  996.       END;
  997.       IF NOT loaded THEN
  998.         Put16(LEA + (An MOD 8)*LS9 + ea);
  999.         Ext(x);
  1000.       END;
  1001.       IF mode IN ItSet{RindMd,RidxMd,AregMd} THEN
  1002.         IF newA THEN ReleaseReg(R) END;
  1003.       END;
  1004.       IF mode = RidxMd THEN ReleaseReg(RX) END;
  1005.       (* resulting mode is 'AregMd'. *)
  1006.       SetregMd(x, An, typ);
  1007.     END (*WITH*);
  1008.   END LoadAdr;
  1009.  
  1010.   PROCEDURE Move(VAR x, y : Item);
  1011.     (*                                                  *)
  1012.     (*    move simple type x  --->>>  simple type y     *)
  1013.     (* simple type means : item of size byte/word/long. *)
  1014.     (*                                                  *)
  1015.     VAR op, ea1, ea2 : CARDINAL; lv : LONGINT;
  1016.         cload, domove : BOOLEAN; szx, szy : WidType;
  1017.   BEGIN
  1018.     IF x.mode = cocMd THEN LoadCC(x) END;
  1019.     Isz(y,szy); Isz(x,szx);
  1020.     Gea(x,ea1); Gea(y,ea2);
  1021.     cload := (x.mode = conMd); domove := TRUE;
  1022.     IF cload THEN lv := LongVal(x) END;
  1023.     IF y.mode = DregMd THEN
  1024.       (* load to D-Register : *)
  1025.       ea2 := (y.R MOD 8)*LS9;
  1026.       IF cload THEN
  1027.         (* constant load to D-Register : *)
  1028.         IF (lv >= -128D) & (lv <= 127D) THEN
  1029.           Put16(MOVEQ + ea2 + (VAL(CARDINAL, WordVal(x)) MOD 256));
  1030.         ELSIF (szx <= word) THEN
  1031.           Put16(MOVEW + ea2 + IMM);
  1032.           Put16(WordVal(x));
  1033.         ELSE
  1034.           Put16(MOVEL + ea2 + IMM);
  1035.           Put32(lv);
  1036.         END;
  1037.       ELSE
  1038.         (* variable load to D-Register : *)
  1039.         IF x.mode = DregMd THEN domove := (x.R <> y.R) END;
  1040.         IF (x.mode = AregMd) & (szy < long) THEN szy := long END;
  1041.         op := MoveCode[szy];
  1042.         IF domove THEN
  1043.           Put16(op + ea2 + ea1);
  1044.           Ext(x); (* source effective address extension *)
  1045.         END;
  1046.       END;
  1047.       y.wid := szy;
  1048.     ELSIF y.mode = AregMd THEN
  1049.       (* load to A-Register : always sign extends the data. *)
  1050.       ea2 := (y.R MOD 8)*LS9;
  1051.       IF cload THEN
  1052.         (* constant load to A-Register : always load long. *)
  1053.         IF (lv >= -32768D) & (lv <= 32767D) THEN
  1054.           Put16(MOVEAW + ea2 + IMM);
  1055.           Put16(WordVal(x));
  1056.         ELSE
  1057.           Put16(MOVEAL + ea2 + IMM);
  1058.           Put32(lv);
  1059.         END;
  1060.       ELSE
  1061.         (* variable load to A-Register : *)
  1062.         IF x.mode = AregMd THEN domove := (x.R <> y.R) END;
  1063.         IF x.mode = DregMd THEN szy := x.wid END;
  1064.         IF szy = byte THEN err(293) END;
  1065.         op := MoveCode[szy] + ADIR*LS3;
  1066.         IF domove THEN
  1067.           Put16(op + ea2 + ea1);
  1068.           Ext(x); (* source extension *)
  1069.         END;
  1070.       END;
  1071.     ELSE
  1072.       (* move to memory : *)
  1073.       IF (x.mode = AregMd) & (szy < long) THEN err(292) END;
  1074.       IF (y.mode = stkMd) THEN
  1075.         (* destination on top of stack : gives -(SP). *)
  1076.         ea2 := ADEC + SP;
  1077.         SetstkMd(y, y.typ);
  1078.       END;
  1079.       IF cload & (lv = 0D) THEN
  1080.         Put16(CLR + szy*LS6 + ea2);
  1081.         Ext(y);  (* extend destination *)
  1082.       ELSIF (x.mode <> stkMd) OR (y.mode <> stkMd) THEN
  1083.         op := MoveCode[szy] + Iea(ea2)*LS6 + ea1;
  1084.         Put16(op);
  1085.         Ext(x);  (* extend source *)
  1086.         Ext(y);  (* extend destination *)
  1087.       END;
  1088.     END;
  1089.   END Move;
  1090.  
  1091.   PROCEDURE LoadD(VAR x : Item);
  1092.     (* load simple type x to a D-Register. *)
  1093.     VAR y : Item; Dn : Register;
  1094.   BEGIN
  1095.     WITH x DO
  1096.       IF mode < DregMd THEN
  1097.         GetReg(Dn,Dreg);
  1098.         SetregMd(y, Dn, typ);
  1099.         Move(x,y);
  1100.         Release(x);
  1101.         x := y;
  1102.       ELSIF mode = cocMd THEN LoadCC(x)
  1103.       ELSIF mode > DregMd THEN
  1104.         err(230); Release(x);
  1105.         SetregMd(x, D0, typ);
  1106.       END;
  1107.     END (*WITH*);
  1108.   END LoadD;
  1109.  
  1110.   PROCEDURE CheckPointer(VAR x : Item);
  1111.     (* check x to be a non-NIL pointer *)
  1112.   BEGIN
  1113.     IF NOT(rngchk) OR (x.typ = addrtyp) THEN RETURN END;
  1114.     LoadD(x);
  1115.     Put16(BNE + 12); (* if NOT NIL-pointer *)
  1116.     GenHalt(5);      (* halt if NIL-pointer *)
  1117.   END CheckPointer;
  1118.  
  1119.   PROCEDURE LoadP(VAR x : Item);
  1120.     (* load simple type or pointer to a pointer/address-register. *)
  1121.     VAR y : Item; An : Register;
  1122.   BEGIN
  1123.     WITH x DO
  1124.       IF (mode IN ItSet{RindMd,RidxMd}) & NOT(Islocked(R)) THEN
  1125.         SetregMd(y, R, typ);
  1126.         Move(x,y);
  1127.         SetbusyReg(R);  (* do NOT release register R *)
  1128.         IF mode = RidxMd THEN ReleaseReg(RX) END;
  1129.         x := y;
  1130.       ELSIF (mode < AregMd) OR (mode = DregMd) THEN
  1131.         GetReg(An,Areg);
  1132.         SetregMd(y, An, typ);
  1133.         Move(x,y);
  1134.         Release(x);
  1135.         x := y;
  1136.       ELSIF (mode <> AregMd) THEN
  1137.         err(230); Release(x);
  1138.         SetregMd(x, A0+8, typ);
  1139.       END;
  1140.     END (*WITH*);
  1141.   END LoadP;
  1142.  
  1143.   PROCEDURE LoadX(VAR x : Item; req : WidType);
  1144.     (* load simple type x to a D-Register and    *)
  1145.     (* sign extend it to the width given by req. *)
  1146.  
  1147.     VAR y : Item; Dn : Register; sz : WidType;
  1148.         cload, signar : BOOLEAN; lv : LONGINT;
  1149.  
  1150.     PROCEDURE NewLoadX(VAR old, new : Item);
  1151.     BEGIN
  1152.       GetReg(Dn,Dreg);
  1153.       SetregMd(new, Dn, old.typ);
  1154.       IF NOT(signar) & (sz < req) & (sz < long) THEN
  1155.         Put16(MOVEQ + Dn*LS9);
  1156.       END;
  1157.       Move(old,new);
  1158.       Release(old);
  1159.       IF signar & (sz < req) & (sz < long) THEN
  1160.         IF sz = byte THEN Put16(EXTW + Dn) END;
  1161.         IF req = long THEN Put16(EXTL + Dn) END;
  1162.       END;
  1163.       new.wid := req;
  1164.     END NewLoadX;
  1165.  
  1166.   BEGIN (* LoadX *)
  1167.     IF x.mode = cocMd THEN LoadCC(x) END;
  1168.     Isz(x,sz);
  1169.     cload := SimpleC(x); (* Real constants not included *)
  1170.     signar := SignedT(x);
  1171.     WITH x DO
  1172.       IF cload THEN
  1173.         (* constants always loaded to long width. *)
  1174.         lv := LongVal(x);
  1175.         GetReg(Dn,Dreg); SetregMd(y, Dn, typ);
  1176.         IF (lv >= -128D) & (lv <= 127D) THEN
  1177.           Put16(MOVEQ + Dn*LS9 + (VAL(CARDINAL, WordVal(x)) MOD 256));
  1178.         ELSE (* not quick *)
  1179.           Put16(MOVEL + Dn*LS9 + IMM);
  1180.           Put32(lv);
  1181.         END;
  1182.         y.wid := req; (* long satisfies req anyway *)
  1183.         x := y;
  1184.       ELSIF (mode = DregMd) THEN
  1185.         (* x is already in a D-Register. *)
  1186.         IF wid < req THEN
  1187.           IF req = word THEN
  1188.             IF sz = byte THEN
  1189.               IF signar THEN Put16(EXTW + R)
  1190.               ELSE (* unsigned types *)
  1191.                 Put16(ANDI + word*LS6 + R);
  1192.                 Put16(377B);
  1193.               END;
  1194.             END;
  1195.           ELSIF req = long THEN
  1196.             IF signar THEN
  1197.               IF sz < long THEN
  1198.                 IF sz = byte THEN Put16(EXTW + R) END;
  1199.                 Put16(EXTL + R);
  1200.               END;
  1201.             ELSE (* unsigned types *)
  1202.               IF sz < long THEN
  1203.                 Put16(ANDI + long*LS6 + R);
  1204.                 IF sz = byte THEN Put32(255D) ELSE Put32(65535D) END;
  1205.               END;
  1206.             END;
  1207.           END;
  1208.         END (*wid < req*);
  1209.         wid := req;
  1210.       ELSIF (mode <= AregMd) THEN
  1211.         (* Real constants fall into this variant. *)
  1212.         NewLoadX(x,y);
  1213.         x := y;
  1214.       ELSE
  1215.         err(230); Release(x);
  1216.         SetregMd(x, D0, typ);
  1217.       END;
  1218.     END (*WITH*);
  1219.   END LoadX;
  1220.  
  1221.   PROCEDURE MoveAdr(VAR x, y : Item);
  1222.     (*   ADR(x)   --->>>  y      *)
  1223.     VAR op, src, dst : CARDINAL; o, s : StrPtr;
  1224.   BEGIN
  1225.     WITH x DO
  1226.       o := typ;   (* save original type of x *)
  1227.       s := y.typ; (* save original type of y *)
  1228.       IF (mode IN ItSet{stkMd,AregMd,DregMd,cocMd,typMd,codMd,fltMd})
  1229.       OR ((mode = conMd) & (typ <> stringtyp)) THEN
  1230.         err(231); (* no effective address possible *)
  1231.         Release(x); SetregMd(x, A0+8, undftyp);
  1232.       END;
  1233.       IF y.mode = stkMd THEN (* push address of x *)
  1234.         op := 0;
  1235.         IF (mode < conMd) & indir & (off = 0) THEN
  1236.           indir := FALSE; op := MVEMSP;
  1237.         END;
  1238.         IF mode = procMd THEN GeaP(x,src) ELSE Gea(x,src) END;
  1239.         IF mode = AregMd THEN
  1240.           op := MVEMSP;   (* MOVE.L An,-(SP) *)
  1241.         ELSIF op = 0 THEN
  1242.           op := PEA;
  1243.         END;
  1244.         Put16(op + src);
  1245.         Ext(x);
  1246.       ELSE (* move address of x *)
  1247.         IF (mode < conMd) & indir & (off = 0) THEN
  1248.           indir := FALSE;
  1249.         ELSE
  1250.           LoadAdr(x);
  1251.         END;
  1252.         typ := addrtyp; y.typ := addrtyp;
  1253.         Move(x,y);
  1254.         IF y.mode = DregMd THEN y.wid := long END;
  1255.       END;
  1256.       typ := o;    (* restore original type of x *)
  1257.       y.typ := s;  (* restore original type of y *)
  1258.     END (*WITH*);
  1259.     Release(x);  (* release associated registers *)
  1260.   END MoveAdr;
  1261.  
  1262.   PROCEDURE MoveBlock(VAR x, y : Item; sz : INTEGER; isstring : BOOLEAN);
  1263.     (*  Move a block of 'sz' bytes from x to y.  *)
  1264.     (*                                           *)
  1265.     (*  x.mode = stkMd :  block comes from stack *)
  1266.     (*  y.mode = stkMd :  block goes onto stack  *)
  1267.     (*                                           *)
  1268.     (* Dogma : the implementation below presumes *)
  1269.     (* -----   that all arrays and records are   *)
  1270.     (*         allocated on a Word-boundary.     *)
  1271.     (*                                           *)
  1272.     VAR hsz, op, src, dst : CARDINAL; z : Item; xmode : ItemMode;
  1273.   BEGIN
  1274.     IF (x.mode <> stkMd) OR (y.mode <> stkMd) THEN
  1275.       xmode := x.mode; (* save original mode of source op. *)
  1276.       IF y.mode = stkMd THEN
  1277.         StackTop( - sz );
  1278.         y.mode := RindMd; (* transform 'stkMd' to 'RindMd' *)
  1279.       END;
  1280.       IF x.mode = stkMd THEN
  1281.         x.mode := RindMd; (* transform 'stkMd' to 'RindMd' *)
  1282.       END;
  1283.       LoadAdr(x); src := AINC + (x.R MOD 8);
  1284.       LoadAdr(y); dst := AINC + (y.R MOD 8);
  1285.       op := MOVEB; hsz := sz;
  1286.       IF NOT isstring THEN
  1287.         (* Note : always byte - move for Strings due to DBEQ! *)
  1288.         IF    (hsz MOD 4) = 0 THEN op := MOVEL; hsz := hsz DIV 4
  1289.         ELSIF (hsz MOD 2) = 0 THEN op := MOVEW; hsz := hsz DIV 2
  1290.         END;
  1291.       END;
  1292.       op := op + Iea(dst)*LS6 + src;
  1293.       IF    hsz = 1 THEN Put16(op)
  1294.       ELSIF hsz = 2 THEN Put16(op); Put16(op)
  1295.       ELSIF hsz = 3 THEN Put16(op); Put16(op); Put16(op)
  1296.       ELSIF hsz > 0 THEN
  1297.         SetconMd(z, hsz - 1, inttyp);
  1298.         LoadD(z);
  1299.         Put16(op);
  1300.         IF isstring THEN Put16(DBEQ + z.R)
  1301.         ELSE Put16(DBRA + z.R) END;
  1302.         Put16(177774B);
  1303.         ReleaseReg(z.R);
  1304.       END;
  1305.       IF xmode = stkMd THEN StackTop( sz ) END;
  1306.     END;
  1307.   END MoveBlock;
  1308.  
  1309.   PROCEDURE ConvertTyp(functyp : StrPtr; VAR x : Item);
  1310.     VAR fs, xs : INTEGER; szf, szx : WidType; y : Item;
  1311.   BEGIN
  1312.     SetregMd(y, D0, functyp);  (* dummy for SimpleT *)
  1313.     WITH x DO
  1314.       fs := functyp^.size;
  1315.       xs := typ^.size;
  1316.       IF fs <> xs THEN
  1317.         IF SimpleT(x) & SimpleT(y) THEN
  1318.           Isz(x,szx); Isz(y,szf);
  1319.           IF mode = conMd THEN
  1320.             SetconMd(x, LongVal(x), functyp);
  1321.           ELSIF (mode <= DregMd) OR (mode = cocMd) THEN
  1322.             IF szf <= szx THEN LoadD(x)
  1323.             ELSE LoadX(x,szf) END;
  1324.           ELSE err(81); Release(x);
  1325.           END;
  1326.         ELSE err(81); Release(x);
  1327.         END;
  1328.       END;
  1329.       typ := functyp; (* type of x IS changed ! *)
  1330.       IF (mode = DregMd) & SimpleT(y) THEN Isz(y,wid) END;
  1331.     END (*WITH*);
  1332.   END ConvertTyp;
  1333.  
  1334.   PROCEDURE CallSystem(sysp : CARDINAL);
  1335.     (* call System.#sysp where sysp = ordinal of procedure.  *)
  1336.   BEGIN
  1337.     ExternalCall(maxM - 1, sysp);
  1338.   END CallSystem;
  1339.  
  1340.   PROCEDURE GenHalt(haltindex : CARDINAL);
  1341.   BEGIN
  1342.     haltindex := haltindex MOD 256;
  1343.     IF (haltindex <> 0) & NOT(rngchk) THEN RETURN END;
  1344.     Put16(MOVEQ + D0*LS9 + haltindex);
  1345.     CallSystem(HALTX);
  1346.   END GenHalt;
  1347.  
  1348.   PROCEDURE Int32Ari(inst : CARDINAL; VAR x, y : Item);
  1349.     (* Interface to the 32-Bit arithmetic in System.  *)
  1350.     (*     x  (inst)  y   ---->>>   (D0.L,D1.L)       *)
  1351.     VAR yy : Item;
  1352.   BEGIN
  1353.     SetregMd(yy, D1, dbltyp); y.typ := dbltyp;
  1354.     Put16(MOVEL + x.R);      (* keep x.R reserved *)
  1355.     Move(y,yy);
  1356.     Release(y);              (* let go y's registers *)
  1357.     CallSystem(inst);
  1358.     (* result in register-pair (D0.L,D1.L). *)
  1359.     (* x.wid := long; *)
  1360.   END Int32Ari;
  1361.  
  1362.   PROCEDURE Op1(op : CARDINAL; VAR x : Item);
  1363.     (* generate instructions with 1 operand represented   *)
  1364.     (* by an eff. address in bits [0..5] and its variable *)
  1365.     (* size in bits [6..7] of the instruction word.       *)
  1366.     (* Used for CLR, TST, NEG, COM (=NOT), INC1, DEC1.    *)
  1367.     (* Not used for JSR, JMP, PEA, Scc because these      *)
  1368.     (* instructions have a fixed size.                    *)
  1369.     (* Note : x can be a memory location or on TOS.       *)
  1370.     VAR ea : CARDINAL; sz : WidType;
  1371.   BEGIN
  1372.     Isz(x,sz);
  1373.     Gea(x,ea);
  1374.     WITH x DO
  1375.       IF mode = stkMd THEN
  1376.         (* change (SP)+ to (SP). *)
  1377.         (* for TST the operand is popped from stack! *)
  1378.         IF op <> TST THEN ea := AIDR + SP END;
  1379.       END;
  1380.       Put16(op + sz*LS6 + ea);
  1381.       Ext(x);
  1382.       IF mode = DregMd THEN wid := sz END;
  1383.     END (*WITH*);
  1384.   END Op1;
  1385.  
  1386.   PROCEDURE Power2(VAR x : Item; VAR exp2 : CARDINAL) : BOOLEAN;
  1387.     (* Note : negative numbers must NOT return as power of 2. *)
  1388.     VAR pw2 : BOOLEAN;
  1389.         v   : LONGINT;
  1390.   BEGIN
  1391.     exp2 := 0; pw2 := FALSE;
  1392.     IF SimpleC(x) THEN
  1393.       v := LongVal(x);
  1394.       pw2 := (v >= 1D);              (* 1 = 2**0 *)
  1395.       WHILE (v > 1D) & pw2 DO
  1396.         pw2 := NOT ODD(v);
  1397.         v := SHIFT(v, -1);           (* v := v DIV 2D;  *)
  1398.         INC(exp2);                   (* side effect of Power2 *)
  1399.       END;
  1400.     END;
  1401.     RETURN pw2                       (* 0 <= exp2 <= 31 *)
  1402.   END Power2;
  1403.  
  1404.   PROCEDURE MulPw2(VAR x : Item; exp : CARDINAL; ovfl : BOOLEAN);
  1405.     (*       x * (power of 2)               *)
  1406.     (* relevant is the width, not the size! *)
  1407.     VAR op : CARDINAL; Dn : Register;
  1408.   BEGIN
  1409.     IF exp <> 0 THEN
  1410.       IF SignedT(x) THEN op := ASL ELSE op := LSL END;
  1411.       op := op + x.wid*LS6 + x.R;
  1412.       IF exp IN {1..8} THEN (* immediate shift *)
  1413.         Put16(op + (exp MOD 8)*LS9);
  1414.       ELSE (* register by register shift *)
  1415.         GetReg(Dn,Dreg);
  1416.         Put16(MOVEQ + Dn*LS9 + exp);
  1417.         Put16(op + Dn*LS9 + LS5);
  1418.         ReleaseReg(Dn);
  1419.       END;
  1420.       IF ovfl THEN OvflTrap(SignedT(x)) END;
  1421.       (* do not change x.wid *)
  1422.     END (*exp <> 0*);
  1423.   END MulPw2;
  1424.  
  1425.   PROCEDURE MUL2(VAR x, y : Item; ovfl : BOOLEAN);
  1426.     (*  x  *  y  --->>  x  *)
  1427.     VAR op, ea, pw2 : CARDINAL; szx, szy : WidType;
  1428.         signar, loady : BOOLEAN;
  1429.   BEGIN
  1430.     Isz(x,szx); Isz(y,szy);
  1431.     signar := SignedT(x) OR SignedT(y);
  1432.     loady  := y.mode IN ItSet{AregMd,stkMd};
  1433.     IF szx < long THEN (* szy < long expected *)
  1434.       (* 16 * 16 bits *)
  1435.       IF (szy = byte) OR loady THEN LoadX(y,word) END;
  1436.       LoadX(x,word);  (* assert DregMd for destination *)
  1437.       IF Power2(y,pw2) THEN MulPw2(x,pw2,ovfl)
  1438.       ELSE
  1439.         IF signar THEN op := MULS ELSE op := MULU END;
  1440.         Gea(y,ea);
  1441.         Put16(op + x.R*LS9 + ea);
  1442.         Ext(y);
  1443.         x.wid := long;
  1444.         IF ovfl THEN OvflCheck(x.R, signar) END;
  1445.       END;
  1446.     ELSE
  1447.       (* 32 * 32 bits *)
  1448.       IF (szy < long) OR loady THEN LoadX(y,long) END;
  1449.       LoadX(x,long);  (* assert DregMd for destination *)
  1450.       IF Power2(y,pw2) THEN MulPw2(x,pw2,ovfl)
  1451.       ELSE
  1452.         IF signar THEN op := MULS32 ELSE op := MULU32 END;
  1453.         Int32Ari(op,x,y);
  1454.         IF ovfl THEN OvflTrap(signar) END;
  1455.         (* 64-bit result is in D0.L/D1.L :           *)
  1456.         (* x.R remains reserved, x.wid remains long. *)
  1457.         Put16(MOVEL + x.R*LS9 + D0);
  1458.       END;
  1459.     END;
  1460.     Release(y);
  1461.   END MUL2;
  1462.  
  1463.   PROCEDURE SHI2(inst : CARDINAL; VAR x, y : Item);
  1464.     (*  shift left/right x by y.  *)
  1465.     VAR op, cv : CARDINAL; szx : WidType; lv : LONGINT; imm : BOOLEAN;
  1466.   BEGIN
  1467.     IF (x.mode = stkMd) & (y.mode = stkMd) THEN LoadD(y) END;
  1468.     LoadD(x);
  1469.     Isz(x,szx);
  1470.     op := inst + szx*LS6 + x.R; (* register to be shifted *)
  1471.     imm := FALSE;
  1472.     IF SimpleC(y) THEN
  1473.       lv := LongVal(y);
  1474.       IF (lv >= 1D) & (lv <= 8D) THEN imm := TRUE END;
  1475.     END;
  1476.     IF imm THEN (* immediate shift : value 0 excluded *)
  1477.       cv := VAL(CARDINAL, lv) MOD 8;
  1478.       Put16(op + cv*LS9);
  1479.     ELSE (* register by register shift *)
  1480.       LoadD(y);                 (* load shift count *)
  1481.       op := op + y.R*LS9 + LS5; (* indicates register shift *)
  1482.       (* shift is modulo 64 : no chechs are made for *)
  1483.       (* positive or negative values of shift count. *)
  1484.       Put16(op);
  1485.     END;
  1486.     x.wid := szx; (* resulting width of D-Register *)
  1487.     Release(y);
  1488.   END SHI2;
  1489.  
  1490.   PROCEDURE LOG2(inst : CARDINAL; VAR x, y : Item);
  1491.     (* the logical operators AND, OR, EOR.  *)
  1492.     (*      x   AND   y  --->>   x          *)
  1493.     (*      x   OR    y  --->>   x          *)
  1494.     (*      x   EOR   y  --->>   x          *)
  1495.     (* Note : x can be a memory location *)
  1496.     (*        or on top of stack.        *)
  1497.     VAR op, eax, eay : CARDINAL; szx, szy : WidType;
  1498.   BEGIN
  1499.     Isz(x,szx); Isz(y,szy);
  1500.     Gea(x,eax);
  1501.     IF x.mode = stkMd THEN eax := AIDR + SP (* gives (SP) *) END;
  1502.     IF SimpleC(y) & (x.mode <> AregMd) THEN
  1503.       (* ANDI / ORI / EORI *)
  1504.       IF inst = ANDL THEN op := ANDI
  1505.       ELSIF inst = ORL THEN op := ORI
  1506.       ELSE op := EORI END;
  1507.       Put16(op + szx*LS6 + eax);
  1508.       Ext(y); (* source extension first *)
  1509.       Ext(x); (* destination extension  *)
  1510.     ELSE
  1511.       IF (x.mode = stkMd) & (y.mode = stkMd) THEN LoadD(y) END;
  1512.       IF x.mode = AregMd THEN LoadD(x); Gea(x,eax) END;
  1513.       op := inst + szx*LS6;
  1514.       Gea(y,eay);
  1515.       IF (x.mode = DregMd) & (inst <> EORL) THEN
  1516.         (* destination is D-Register : *)
  1517.         Put16(op + x.R*LS9 + eay);
  1518.         Ext(y); (* source extension *)
  1519.       ELSE
  1520.         (* destination is memory location or inst = EOR. *)
  1521.         (* assert source operand in D-Register.          *)
  1522.         LoadD(y);
  1523.         IF (inst <> EORL) THEN
  1524.           op := op + LS8;
  1525.         END;
  1526.         Put16(op + y.R*LS9 + eax);
  1527.         Ext(x); (* destination extension *)
  1528.       END;
  1529.     END;
  1530.     IF x.mode = DregMd THEN x.wid := szx END;
  1531.     Release(y);
  1532.   END LOG2;
  1533.  
  1534.   PROCEDURE DivPw2(VAR x : Item; exp : CARDINAL; modulus : BOOLEAN);
  1535.     VAR m : LONGINT; y : Item;
  1536.   BEGIN
  1537.     IF exp = 0 THEN (* DIV/MOD 1 *)
  1538.       IF modulus THEN Release(x); SetconMd(x, 0D, x.typ) END;
  1539.       (* else no change if x DIV 1 *)
  1540.     ELSE
  1541.       LoadD(x);
  1542.       IF NOT modulus THEN (* DIV *)
  1543.         SetconMd(y, exp, inttyp);
  1544.         IF SignedT(x) THEN SHI2(ASR,x,y)
  1545.         ELSE SHI2(LSR,x,y)
  1546.         END;
  1547.       ELSE (* MOD *)
  1548.         m := mask[exp];  (* 2**exp - 1 *)
  1549.         SetconMd(y, m, x.typ);
  1550.         LOG2(ANDL,x,y);
  1551.       END;
  1552.     END;
  1553.     (* x.wid is set by SHI2 and LOG2 *)
  1554.     Release(y);
  1555.   END DivPw2;
  1556.  
  1557.   PROCEDURE DIV2(VAR x, y : Item; modulus : BOOLEAN);
  1558.     (*  x  DIV/MOD  y  --->>  x  *)
  1559.     VAR op, ea, pw2 : CARDINAL; szx, szy : WidType;
  1560.         signar, loady : BOOLEAN;
  1561.   BEGIN
  1562.     Isz(x,szx); Isz(y,szy);
  1563.     signar := SignedT(x) OR SignedT(y);
  1564.     loady  := y.mode IN ItSet{AregMd,stkMd};
  1565.     IF szx < long THEN (* szy < long expected *)
  1566.       (* 32 DIV/MOD 16 bits *)
  1567.       IF (szy = byte) OR loady THEN LoadX(y,word) END;
  1568.       IF NOT(signar) & Power2(y,pw2) THEN DivPw2(x,pw2,modulus)
  1569.       ELSE (* extend destination to 32 bits *)
  1570.         LoadX(x,long); (* assert DregMd for destination *)
  1571.         IF signar THEN op := DIVS ELSE op := DIVU END;
  1572.         Gea(y,ea);
  1573.         Put16(op + x.R*LS9 + ea);
  1574.         Ext(y); (* extend the source *)
  1575.         OvflTrap(signar); (* for security reasons *)
  1576.         (* quotient in bits [0..15], remainder in bits [16..31] *)
  1577.         IF modulus THEN Put16(SWAP + x.R) END;
  1578.         x.wid := word; (* resulting width *)
  1579.       END;
  1580.     ELSE
  1581.       (* 32 DIV/MOD 32 bits *)
  1582.       IF (szy < long) OR loady THEN LoadX(y,long) END;
  1583.       IF NOT(signar) & Power2(y,pw2) THEN DivPw2(x,pw2,modulus)
  1584.       ELSE
  1585.         LoadX(x,long); (* assert DregMd for destination *)
  1586.         IF signar THEN op := DIVS32 ELSE op := DIVU32 END;
  1587.         Int32Ari(op,x,y);
  1588.         (* quotient in register D0.L, remainder in D1.L : *)
  1589.         (* x.R remains reserved, x.wid remains long.      *)
  1590.         op := MOVEL + x.R*LS9;
  1591.         IF modulus THEN Put16(op + D1) ELSE Put16(op + D0) END;
  1592.       END;
  1593.     END;
  1594.     Release(y);
  1595.   END DIV2;
  1596.  
  1597.   PROCEDURE ADD2(inst : CARDINAL; VAR x, y : Item);
  1598.     (*       x  +  y    --->>   x        *)
  1599.     (*       x  -  y    --->>   x        *)
  1600.     (* Note : x can be a memory location *)
  1601.     (*        or on top of stack.        *)
  1602.     VAR op, eax, eay : CARDINAL; szx, szy : WidType;
  1603.         cadd : BOOLEAN; lv : LONGINT;
  1604.   BEGIN
  1605.     Isz(x,szx); Isz(y,szy);
  1606.     Gea(x,eax);
  1607.     IF x.mode = stkMd THEN eax := AIDR + SP (* gives (SP) *) END;
  1608.     cadd := SimpleC(y);
  1609.     IF cadd THEN lv := LongVal(y) END;
  1610.     IF cadd & (x.mode <> AregMd) THEN
  1611.       IF (lv >= 1D) & (lv <= 8D) THEN
  1612.         IF inst = ADD THEN op := ADDQ ELSE op := SUBQ END;
  1613.         eay := VAL(CARDINAL, lv) MOD 8;
  1614.         Put16(op + eay*LS9 + szx*LS6 + eax);
  1615.         Ext(x);
  1616.       ELSIF (lv <> 0D) THEN
  1617.         IF inst = ADD THEN op := ADDI ELSE op := SUBI END;
  1618.         Put16(op + szx*LS6 + eax);
  1619.         Ext(y); (* extend source constant first *)
  1620.         Ext(x); (* extend destination *)
  1621.       END;
  1622.     ELSE
  1623.       IF inst = ADD THEN op := ADD ELSE op := SUB END;
  1624.       IF (x.mode = stkMd) & (y.mode = stkMd) THEN LoadD(y) END;
  1625.       Gea(y,eay);
  1626.       IF x.mode = DregMd THEN
  1627.         (* destination is D-Register : *)
  1628.         op := op + (x.R MOD 8)*LS9;
  1629.         IF y.mode = AregMd THEN
  1630.           (* allow word/long only for source in A-Reg. *)
  1631.           IF szy = byte THEN err(288) END;
  1632.         END;
  1633.         Put16(op + szx*LS6 + eay);
  1634.         Ext(y); (* extend source *)
  1635.       ELSIF x.mode = AregMd THEN
  1636.         (* destination is A-Register : *)
  1637.         op := op + (x.R MOD 8)*LS9;
  1638.         (* allow long operation only. *)
  1639.         IF szx < long THEN err(287) END;
  1640.         Put16(op + 700B + eay); (* 700B generates ADDA.L *)
  1641.         Ext(y); (* extend source *)
  1642.       ELSE
  1643.         (* destination is memory location : *)
  1644.         (* assert source op. in D-Register. *)
  1645.         LoadD(y);
  1646.         op := op + y.R*LS9 + LS8;
  1647.         Put16(op + szx*LS6 + eax);
  1648.         Ext(x); (* extend destination *)
  1649.       END;
  1650.     END;
  1651.     IF x.mode = DregMd THEN x.wid := szx END;
  1652.     Release(y);
  1653.   END ADD2;
  1654.  
  1655.   PROCEDURE Cmp2(VAR x, y : Item);
  1656.     (*         x   -   y                 *)
  1657.     (* Note : x can be a memory location *)
  1658.     (*        or on top of stack.        *)
  1659.     VAR op, eax, eay : CARDINAL; szx, szy : WidType; lv : LONGINT;
  1660.   BEGIN
  1661.     Isz(x,szx); Isz(y,szy);
  1662.     Gea(x,eax);
  1663.     IF SimpleC(y) & NOT(x.mode IN ItSet{AregMd,conMd}) THEN
  1664.       (* source is constant : *)
  1665.       lv := LongVal(y);
  1666.       IF lv = 0D THEN Op1(TST,x)   (* x would be popped if stkMd *)
  1667.       ELSE op := CMPI;
  1668.         Put16(op + szx*LS6 + eax); (* x would be popped if stkMd *)
  1669.         Ext(y); (* immediate source *)
  1670.         Ext(x); (* extend destination *)
  1671.       END;
  1672.     ELSIF x.mode = AregMd THEN
  1673.       (* destination is A-Register : *)
  1674.       Gea(y,eay); op := CMP + (x.R MOD 8)*LS9;
  1675.       (* allow long operation only. *)
  1676.       IF szx < long THEN err(287) END;
  1677.       Put16(op + 700B + eay); (* 700B generates CMPA.L *)
  1678.       Ext(y); (* extend source *)
  1679.     ELSE
  1680.       (* destination must be D-Register : *)
  1681.       IF (x.mode = stkMd) & (y.mode = stkMd) THEN LoadD(y) END;
  1682.       LoadD(x);
  1683.       Gea(y,eay); op := CMP + (x.R MOD 8)*LS9;
  1684.       IF y.mode = AregMd THEN
  1685.         (* allow word/long only for source in A-Reg. *)
  1686.         IF szy = byte THEN err(288) END;
  1687.       END;
  1688.       Put16(op + szx*LS6 + eay);   (* y would be popped if stkMd *)
  1689.       Ext(y); (* extend source *)
  1690.     END;
  1691.     Release(y);
  1692.     (* result is in the condition code register! *)
  1693.   END Cmp2;
  1694.  
  1695.   PROCEDURE In2(VAR x, y : Item);
  1696.     (* perform bit-manipulations : BTST.  *)
  1697.     (* y is the destination bit pattern,  *)
  1698.     (* x is the bit number.               *)
  1699.  
  1700.     (*   Caution : NEVER execute a BTST-instruction if     *)
  1701.     (*   the bit number is greather than the width of the  *)
  1702.     (*   set, because hardware takes count modulo 32.      *)
  1703.  
  1704.     VAR op : CARDINAL          *)
  1705.     (*                                         *)
  1706.     (*  y is the shift count of type INTEGER   *)
  1707.     (*  or CARDINAL.                           *)
  1708.     (*  if y >= 0 then shift LEFT.             *)
  1709.     (*  if y <  0 then shift RIGHT.            *)
  1710.     (*                                         *)
  1711.     VAR op, ct, rm : CARDINAL; sz : WidType;
  1712.   BEGIN
  1713.     Isz(x,sz);
  1714.     op := ShiCode[shiftop] + sz*LS6 + (x.R MOD 8); (* initially LEFT shift *)
  1715.     IF y.mode = conMd THEN
  1716.       (* immediate shift count : bit 5 remains 0! *)
  1717.       ct := VAL(CARDINAL, WordVal(y));
  1718.       IF VAL(INTEGER,ct) < 0 THEN
  1719.         op := op - LS8; (* RIGHT shift *)
  1720.         (* Note : overflow-checks must be OFF for compiler! *)
  1721.         ct := ABS(VAL(INTEGER,ct));
  1722.       END;
  1723.       ct := ct MOD 32; (* shift count modulo 32 *)
  1724.       rm := ct MOD 8; ct := ct DIV 8;
  1725.       IF rm <> 0 THEN Put16(op + rm*LS9) END;
  1726.       WHILE ct > 0 DO Put16(op); DEC(ct) END;
  1727.     ELSE
  1728.       (* variable shift count of type INTEGER/CARDINAL : *)
  1729.       (* INTEGER/CARDINAL count treated the same way.    *)
  1730.       (* Note : Hardware takes shift count modulo 64 !   *)
  1731.       LoadX(y,word);                     (* load shift count  *)
  1732.       op := op + y.R*LS9 + LS5;          (* register shift    *)
  1733.       Put16(TST + word*LS6 + y.R);       (* test shift count  *)
  1734.       Put16(BPL + 6);                    (* if count >= 0     *)
  1735.       Put16(NEG + word*LS6 + y.R);       (* abs. value count  *)
  1736.       Put16(op - LS8);                   (* RIGHT shift       *)
  1737.       Put16(BRA + 2);                    (* skip next instr.  *)
  1738.       Put16(op);                         (* LEFT shift        *)
  1739.     END;
  1740.     x.wid := sz; (* resulting width of D-Register *)
  1741.     Release(y);
  1742.   END Ash2;
  1743.  
  1744.   PROCEDURE ConIndex(VAR x : Item; inc : INTEGER);
  1745.     (* called for constant index and field-offset. *)
  1746.     (*   if NOT indir :  adr-field is incremented  *)
  1747.     (*   if indir     :  off-field is incremented. *)
  1748.     VAR i : INTEGER;
  1749.   BEGIN
  1750.     WITH x DO
  1751.       IF mode < conMd THEN
  1752.         (* reference to indir, adr, off allowed. *)
  1753.         IF NOT indir THEN i := adr ELSE i := off END;
  1754.         IF (i >= 0) & (inc <= MaxInt - i)
  1755.         OR (i <  0) & (inc >= MIN(INTEGER) - i) THEN
  1756.           i := i + inc;
  1757.           IF NOT indir THEN adr := i ELSE off := i END;
  1758.         ELSE (* offset overflow *)
  1759.           LoadAdr(x); mode := RindMd; (* transform 'AregMd' to 'RindMd' *)
  1760.           adr := inc;
  1761.         END;
  1762.       ELSE (* all other modes *)
  1763.         err(235);
  1764.       END;
  1765.     END (*WITH*);
  1766.   END ConIndex;
  1767.  
  1768.   PROCEDURE Normalize(VAR x : Item; i : INTEGER);
  1769.     (* normalize x with the low-bound i *)
  1770.     VAR op : CARDINAL; y : Item;
  1771.   BEGIN
  1772.     IF i <> 0 THEN
  1773.       (* Note : overflow-checks must be OFF for compiler! *)
  1774.       IF i > 0 THEN op := SUB ELSE op := ADD; i := ABS(i) END;
  1775.       SetconMd(y, i, x.typ);
  1776.       ADD2(op,x,y);
  1777.     END;
  1778.   END Normalize;
  1779.  
  1780.   PROCEDURE CheckHigh(VAR x, high : Item);
  1781.     (* check item associated with x to be in the   *)
  1782.     (* range indicated by [ 0.. (high) ].          *)
  1783.     (* Note : CHK treats operand and upper-bound   *)
  1784.     (*        as signed 2's complement integers!   *)
  1785.     VAR ea : CARDINAL; sz, hsz : WidType;
  1786.   BEGIN
  1787.     IF NOT rngchk THEN RETURN END;
  1788.     LoadD(x); (* assert x to be loaded into a D-register *)
  1789.     Isz(high,hsz); Isz(x,sz);
  1790.     IF sz = word THEN (* use CHK-instruction *)
  1791.       IF hsz <> word THEN LoadD(high) END;
  1792.       Gea(high,ea);
  1793.       Put16(CHK + x.R*LS9 + ea);
  1794.       Ext(high);
  1795.     ELSE (* use CMP-instruction *)
  1796.       IF hsz <> sz THEN LoadX(high,sz) END;
  1797.       Gea(high,ea);
  1798.       Put16(CMP + x.R*LS9 + sz*LS6 + ea);
  1799.       Ext(high);
  1800.       Put16(BLS + 4);
  1801.       Put16(CHK + x.R*LS9 + IMM); (* trap always *)
  1802.       Put16(-1);
  1803.     END;
  1804.     Release(high);
  1805.   END CheckHigh;
  1806.  
  1807.   PROCEDURE CheckClimit(VAR x : Item; limit : LONGINT);
  1808.     (* check item associated with x to be in the   *)
  1809.     (* range indicated by [ 0 .. limit ].          *)
  1810.     (* Note : Trap taken always if limit < 0.      *)
  1811.     (*        CHK treats operand and upper-bound   *)
  1812.     (*        as signed 2's complement integers!   *)
  1813.     VAR sz : WidType;
  1814.   BEGIN
  1815.     IF NOT rngchk THEN RETURN END;
  1816.     IF (limit < 0D) THEN err(286) END; (* invalid limit *)
  1817.     LoadD(x); (* assert x to be loaded into a D-register *)
  1818.     Isz(x,sz);
  1819.     IF sz = word THEN (* use CHK-instruction *)
  1820.       Put16(CHK + x.R*LS9 + IMM);
  1821.       Put16(VAL(INTEGER, limit));
  1822.     ELSE (* use CMP-instruction *)
  1823.       Put16(CMPI + sz*LS6 + x.R);
  1824.       IF sz = long THEN Put32(limit)
  1825.       ELSE Put16(VAL(INTEGER, limit));
  1826.       END;
  1827.       Put16(BLS + 4);
  1828.       Put16(CHK + x.R*LS9 + IMM); (* trap always *)
  1829.       Put16(-1);
  1830.     END;
  1831.   END CheckClimit;
  1832.  
  1833.   PROCEDURE CheckRange(VAR x: Item; min, max, BndAdr: INTEGER);
  1834.     (* check x in the constant range [ min .. max ] *)
  1835.     VAR htyp : StrPtr; sz : WidType;
  1836.   BEGIN
  1837.     IF NOT rngchk THEN RETURN END;
  1838.     IF SimpleT(x) THEN Isz(x,sz);
  1839.       htyp := x.typ; (* hold original type of x *)
  1840.       LoadX(x,word);
  1841.       IF sz <= word THEN x.typ := inttyp END;
  1842.       Normalize(x, min);
  1843.       IF (max >= min) & ((min >= 0) OR (max <= (MaxInt + min))) THEN
  1844.         max := max - min
  1845.       ELSE
  1846.         err(286); max := 0; (* range distance too big *)
  1847.       END;
  1848.       CheckClimit(x, max);
  1849.       (* Note : overflow-checks must be OFF for compiler! *)
  1850.       (* recover original value of x : *)
  1851.       Normalize(x, - min);
  1852.       x.typ := htyp; (* recover type of x *)
  1853.     END;
  1854.   END CheckRange;
  1855.  
  1856.   PROCEDURE CheckDbltoSingle(VAR x, y : Item);
  1857.     (* range check for assignment of double-word type x *)
  1858.     (* to single-word type y (INTEGER/CARDINAL).        *)
  1859.     VAR Dn : Register;
  1860.   BEGIN
  1861.     IF NOT rngchk THEN RETURN END;
  1862.     LoadD(x);                             (* load long x *)
  1863.     GetReg(Dn,Dreg);                      (* scratch reg. *)
  1864.     IF NOT SignedT(y) THEN
  1865.        Put16(MOVEQ + Dn*LS9);             (* MOVEQ #0,Dn *)
  1866.     END;
  1867.     Put16(MOVEW + Dn*LS9 + x.R);          (* copy word part *)
  1868.     IF SignedT(y) THEN
  1869.       IF NOT SignedT(x) THEN              (* Unsigned to Signed *)
  1870.         Put16(BMI + 6);                   (* exclude values < 0 *)
  1871.       END;
  1872.       Put16(EXTL + Dn);                   (* EXT.L Dn    *)
  1873.     END;
  1874.     Put16(CMP + x.R*LS9 + long*LS6 + Dn); (* CMP.L  Dn,x.R *)
  1875.     Put16(BEQ + 4);                       (* BEQ.S  4      *)
  1876.     Put16(CHK + Dn*LS9 + IMM);            (* CHK    #-1,Dn *)
  1877.     Put16(-1); (* trap always *)
  1878.     ReleaseReg(Dn);
  1879.   END CheckDbltoSingle;
  1880.  
  1881.   PROCEDURE VarIndex(VAR x, y : Item; elsize : INTEGER);
  1882.     (* generate x with a variable index y and elementsize elsize. *)
  1883.     VAR elsz : Item; scale, pw2 : CARDINAL;
  1884.   BEGIN
  1885.     SetconMd(elsz, elsize, y.typ);
  1886.     IF ~Power2(elsz,pw2) & (y.typ = dbltyp) THEN
  1887.       y.typ := inttyp; (* force 16*16Bit MULS.W *)
  1888.       SetconMd(elsz, elsize, y.typ);
  1889.     END;
  1890.     MUL2(y,elsz,FALSE); (* inhibit overflow-checks *)
  1891.     scale := byte;
  1892.     LoadAdr(x);
  1893.     WITH x DO
  1894.       (* transform 'AregMd' to 'RidxMd' *)
  1895.       mode := RidxMd;  indir := FALSE;
  1896.       adr  := 0;       off   := 0;
  1897.       RX   := y.R;     wid   := y.wid;
  1898.       scl  := scale;
  1899.     END (*WITH*);
  1900.   END VarIndex;
  1901.  
  1902.   PROCEDURE GetHigh(VAR x : Item);
  1903.     (* get high-index of dynamic array parameter : *)
  1904.     (*                                             *)
  1905.     (* Caution :  x.typ IS changed !               *)
  1906.     (* -------                                     *)
  1907.   BEGIN
  1908.     WITH x DO
  1909.       IF mode < conMd THEN
  1910.         (* reference to indir, adr, off allowed. *)
  1911.         indir := FALSE;    off := 0;
  1912.         adr   := adr + 4;  typ := hightyp;
  1913.       ELSE err(240)
  1914.       END;
  1915.     END (*WITH*);
  1916.   END GetHigh;
  1917.  
  1918.   PROCEDURE PreLoad(VAR op : Symbol; VAR x , y : Item);
  1919.     (* preload x and/or y for GenOp.       *)
  1920.     (* Note : No-operation for real types! *)
  1921.     VAR z : Item;
  1922.   BEGIN (* do nothing if x is not 'loadable' *)
  1923.     IF NOT(SimpleT(x) & SimpleT(y)) THEN RETURN END;
  1924.     IF (op = times) OR (op = plus) THEN
  1925.       (* symmetric operators : *)
  1926.       IF x.mode <> DregMd THEN
  1927.         IF (y.mode = DregMd) & (y.R IN Rpool) THEN
  1928.           z := x; x := y; y := z;
  1929.         ELSE
  1930.           IF (x.mode = conMd) & (y.mode <= stkMd) THEN
  1931.             z := x; x := y; y := z;
  1932.           END;
  1933.           LoadD(x);
  1934.         END;
  1935.       (* else x already loaded *)
  1936.       END;
  1937.     ELSIF (op = div) OR (op = mod) THEN
  1938.       (* a-symmetric operators : *)
  1939.       (* 32bits / 16bits for DIVS/DIVU ! *)
  1940.       LoadX(x,long);
  1941.     ELSIF (op = slash) OR (op = minus) OR (op = rem) THEN
  1942.       (* a-symmetric operators : *)
  1943.       LoadD(x);
  1944.     ELSIF (op >= eql) & (op <= geq) THEN
  1945.       (* relational operators : *)
  1946.       IF x.mode = conMd THEN
  1947.         (* y.mode <> conMd ! *)
  1948.         z := x; x := y; y := z;
  1949.         IF    op = lss THEN op := gtr
  1950.         ELSIF op = leq THEN op := geq
  1951.         ELSIF op = gtr THEN op := lss
  1952.         ELSIF op = geq THEN op := leq
  1953.         ELSE (* op := op *)
  1954.         END;
  1955.       END;
  1956.     ELSE (* nothing for all other ops *)
  1957.     END;
  1958.   END PreLoad;
  1959.  
  1960.   PROCEDURE DynArray  (VAR x, y : Item);
  1961.     (* generate descriptor for dynamic array parameters : *)
  1962.     (*                                                    *)
  1963.     (* Caution :    guarantee HIGH to be in the range     *)
  1964.     (* -------      0   <=   HIGH   <=   MaxInt.          *)
  1965.     (*                                                    *)
  1966.     CONST ByteSize = 1;
  1967.     VAR high, onstack, e : Item; s : StrPtr;
  1968.         i, elsize : INTEGER; dynbyte   : BOOLEAN;
  1969.   BEGIN
  1970.     dynbyte := (x.typ^.ElemTyp = bytetyp);
  1971.     IF (y.typ^.form = Array) THEN
  1972.       elsize := y.typ^.ElemTyp^.size;
  1973.       IF y.typ^.dyn THEN (* copy existing descriptor *)
  1974.         high := y; GetHigh(high);
  1975.         IF dynbyte & (elsize <> ByteSize) THEN
  1976.           LoadD(high);
  1977.           Inc1(high);         (* enable overflow-check *)
  1978.           SetconMd(e, elsize, high.typ);
  1979.           MUL2(high,e,TRUE);
  1980.           Op1(DEC1,high);     (* disable overflow-check *)
  1981.           IF ovflchk THEN CheckClimit(high, MaxInt - 1) END;
  1982.         END;
  1983.       ELSE (* generate new descriptor *)
  1984.         IF NOT dynbyte THEN
  1985.           s := y.typ^.IndexTyp; i := 0;
  1986.           WITH s^ DO
  1987.             IF form = Range THEN
  1988.               IF (max >= min) & ((min >= 0) OR (max <= (MaxInt + min))) THEN
  1989.                 i := max - min
  1990.               ELSE
  1991.                 err(286); (* range distance too big *)
  1992.               END;
  1993.             END (*Range*);
  1994.           END (*WITH*);
  1995.         ELSE
  1996.           WITH y.typ^ DO
  1997.             IF (form = Array) & (IndexTyp^.form = Range) & (elsize = 1) THEN
  1998.               i := IndexTyp^.max - IndexTyp^.min;
  1999.             ELSE
  2000.               i := size; IF i > 0 THEN DEC(i) END;
  2001.             END;
  2002.           END;
  2003.         END;
  2004.         SetconMd(high, i, hightyp);
  2005.       END;
  2006.     ELSIF (y.typ^.form = String) THEN
  2007.       i := y.val.D1; IF i > 0 THEN DEC(i) END;
  2008.       SetconMd(high, i, hightyp);
  2009.     ELSE
  2010.       i := y.typ^.size; IF i > 0 THEN DEC(i) END;
  2011.       SetconMd(high, i, hightyp);
  2012.       IF y.mode >= conMd THEN err(231) END;
  2013.     END;
  2014.     SetstkMd(onstack, hightyp);
  2015.     Move(high,onstack);
  2016.     MoveAdr(y,onstack);
  2017.     Release(high);
  2018.     Release(y);
  2019.   END DynArray;
  2020.  
  2021.   PROCEDURE CopyDynArray(a, s : INTEGER);
  2022.     (* descriptor at a(MP), element-size is s :  *)
  2023.     (* copy (high+1)*s Bytes from [a(MP)] on top *)
  2024.     (* of stack and update descriptor address.   *)
  2025.     VAR Dn, An, Am : Register; op, src, dst : CARDINAL; x, e : Item;
  2026.   BEGIN
  2027.     SetlocMd(x, a+4, hightyp);
  2028.     LoadD(x); Dn := x.R;
  2029.     (* Caution : value of HIGH must be in positive INTEGER range, *)
  2030.     (* -------   even if HIGH is hold in a longword (LONGINT) !   *)
  2031.     (*           this is essential for the code generation below. *)
  2032.     Inc1(x);         (* (high + 1)     = nr. of elements *)
  2033.     IF (s > 1) THEN  (* (high + 1) * s = nr. of bytes to copy *)
  2034.       SetconMd(e, s, x.typ);
  2035.       MUL2(x,e,TRUE);
  2036.     END;
  2037.     IF ovflchk THEN CheckClimit(x, MaxInt - 1) END;
  2038.     IF ODD(s) THEN
  2039.       (* Note : Dn will never overflow at the INC below ! *)
  2040.       Put16(BTST + LS11 - LS8 + Dn);          (* total nr. of bytes   *)
  2041.       Put16(0);                               (* must be even         *)
  2042.       Put16(BEQ + 2);                         (* skip if already even *)
  2043.       Put16(INC1 + word*LS6 + Dn);            (* if   VAR regs : LONGINT; y : Item; rtyp : StrPtr;
  2044.   BEGIN
  2045.     WITH x DO
  2046.       SetfltMd(y, D0, typ);         (* load into scratch D0/D1 *)
  2047.       FMove(x,y);
  2048.       Release(x);
  2049.       x := y;
  2050.       Release(x);                   (* so D0/D1 are NOT saved *)
  2051.       SaveRegs(regs);               (* save busy registers *)
  2052.       CASE op OF
  2053.         (* define resulting type *)
  2054.         FNEGs,  FABSs  : rtyp := realtyp;
  2055.       | FNEGd,  FABSd  : rtyp := lrltyp;
  2056.       | TRUNCs, TRUNCd : rtyp := dbltyp;
  2057.       | FLOATs, FSHORT : rtyp := realtyp;
  2058.       | FLOATd, FLONG  : rtyp := lrltyp;
  2059.       END;
  2060.       StackTop( - rtyp^.size );     (* space for function result *)
  2061.       SetstkMd(y, typ);
  2062.       FMove(x,y);                   (* push parameter onto stack *)
  2063.       Release(x);                   (* now release the parameter *)
  2064.       CallSystem(op);               (* call the function in System *)
  2065.       SetstkMd(x, rtyp);            (* result on top of stack *)
  2066.       IF regs <> 0D THEN            (* saved regs above result *)
  2067.         IF SimpleT(x) THEN LoadD(x)
  2068.         ELSE LoadF(x) END;
  2069.         RestoreRegs(regs);          (* restore busy registers *)
  2070.       END;
  2071.     END (*WITH*);
  2072.   END FOp1;
  2073.  
  2074.   PROCEDURE FOp2(op : CARDINAL; VAR x, y : Item);
  2075.     (* Interface to the SANE interface in module System *)
  2076.     (* for dyadic Floating-Point-Operations.            *)
  2077.     VAR regs : LONGINT; z : Item; rtyp : StrPtr;
  2078.         Regs : RECORD
  2079.                  CASE :BOOLEAN OF
  2080.                      TRUE : All : LONGINT
  2081.                    | FALSE: X,F,D,A : CHAR
  2082.                  END
  2083.                END;
  2084.   BEGIN
  2085.     SetfltMd(z, D0, y.typ);       (* load y into scratch D0/D1 *)
  2086.     FMove(y,z);                   (* y must be loaded first (stkMd) *)
  2087.     Release(y);
  2088.     y := z;
  2089.     Release(y);                   (* so D0/D1 are NOT saved *)
  2090.     LoadF(x);                     (* load x into scratch Dn/Dn+1 *)
  2091.     Release(x);                   (* so Dn/Dn+1 are NOT saved *)
  2092.     SaveRegs(regs);               (* save busy registers *)
  2093.     CASE op OF
  2094.       (* define resulting type *)
  2095.       FADDs, FSUBs, FMULs, FDIVs, FREMs : rtyp := realtyp;
  2096.     | FADDd, FSUBd, FMULd, FDIVd, FREMd : rtyp := lrltyp;
  2097.     | FCMPs, FCMPd                      : rtyp := notyp;
  2098.     END;
  2099.     IF rtyp <> notyp THEN
  2100.       StackTop( - rtyp^.size );   (* space for function result *)
  2101.     END;
  2102.     SetstkMd(z, x.typ);
  2103.     FMove(x,z);                   (* push x-parameter onto stack *)
  2104.     Release(x);                   (* now release the x-parameter *)
  2105.     SetstkMd(z, y.typ);
  2106.     FMove(y,z);                   (* push y-parameter onto stack *)
  2107.     Release(y);                   (* now release the y-parameter *)
  2108.     CallSystem(op);               (* call the function in System *)
  2109.     SetstkMd(x, rtyp);            (* result on top of stack *)
  2110.     IF regs <> 0D THEN            (* saved regs above result *)
  2111.       IF rtyp <> notyp THEN
  2112.         LoadF(x)                  (* pop function result from stack *)
  2113.       ELSE
  2114.         (* Caution : for FCMPs/FCMPd result is in the CCR :     *)
  2115.         (* -------   avoid the restoring of a single D-Register *)
  2116.         (*           (eventually done by M2HM.RestoreRegs)      *)
  2117.         (*           because this would destroy the CCR !       *)
  2118.         Regs.All := regs; IF Regs.D <> 0C THEN err(244) END;
  2119.       END;
  2120.       RestoreRegs(regs);          (* restore busy registers *)
  2121.     END;
  2122.   END FOp2;
  2123.  
  2124.   PROCEDURE FMonad(op : FMonadic; VAR x : Item);
  2125.     (* interface to the SANE monadic operators :  *)
  2126.     VAR cd : CARDINAL; y : Item;
  2127.   BEGIN
  2128.     cd := 0; (* indicates NO FOp1-call *)
  2129.     CASE op OF
  2130.     | Abs :           cd := FABSs;
  2131.     | NonStand :      cd := FNEGs;
  2132.     | Float :         LoadX(x,long);
  2133.                       x.typ := realtyp; (* essential for FOp1! *)
  2134.                       FOp1(FLOATs,x);
  2135.     | FloatD :        LoadX(x,long);
  2136.                       x.typ := realtyp; (* essential for FOp1! *)
  2137.                       FOp1(FLOATd,x);
  2138.     | Long :          FOp1(FLONG,x);
  2139.     | Short :         FOp1(FSHORT,x);
  2140.     | Trunc :         IF x.typ <> realtyp THEN err(241) END;
  2141.                       FOp1(TRUNCs,x);
  2142.                       LoadD(x);
  2143.                       SetregMd(y, D0, inttyp);
  2144.                       CheckDbltoSingle(x,y);
  2145.     | TruncD :        IF x.typ <> lrltyp THEN err(239) END;
  2146.                       FOp1(TRUNCd,x);
  2147.                       LoadD(x);
  2148.     ELSE              err(200);
  2149.     END (*CASE*);
  2150.     IF cd <> 0 THEN
  2151.       IF x.typ = lrltyp THEN INC(cd,10) (* take double precision *) END;
  2152.       FOp1(cd,x);
  2153.     END;
  2154.   END FMonad;
  2155.  
  2156.   PROCEDURE FDyad(op : FDyadic; VAR x, y : Item);
  2157.     (* interface to the SANE dyadic operators :  *)
  2158.     VAR cd : CARDINAL;
  2159.   BEGIN
  2160.     cd := 0; (* indicates NO FOp2-call *)
  2161.     CASE op OF
  2162.     | plus  :         cd := FADDs;
  2163.     | minus :         cd := FSUBs;
  2164.     | times :         cd := FMULs;
  2165.     | slash :         cd := FDIVs; IF ZeroVal(y) THEN err(205) END;
  2166.     | eql .. geq :    cd := FCMPs;
  2167.     ELSE              err(200);
  2168.     END (*CASE*);
  2169.     IF cd <> 0 THEN
  2170.       IF x.typ = lrltyp THEN INC(cd,10) (* take double precision *) END;
  2171.       FOp2(cd,x,y);
  2172.     END;
  2173.     Release(y);
  2174.   END FDyad;
  2175.  
  2176. END M2HM. (* Copyright Departement Informatik, ETH Zuerich, Switzerland, 1992 *)
  2177.